* [RFC][PATCH 0/6] merge ocaml xenstored and dependencies
@ 2010-03-01 11:59 Vincent Hanquez
2010-03-01 11:59 ` [PATCH 1/6] add ocaml libs (xc/xb/xs/eventchn) Vincent Hanquez
` (5 more replies)
0 siblings, 6 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: 13246 bytes --]
Add ocaml xenstored into xen as an alternative to C xenstored.
The goal is to choose it as the default xenstored on the target machine when it has
been built.
build hook mechanism is not ideal, but should be safe for platform that
cannot build ocaml and/or would have some portability issues.
This is RFC, although the first 5 patches are completly safe since they just
introduce new files and hook with default =n the new files. only the 6th patch
make the default to build ocaml tools with fallback if not available.
Vincent Hanquez (6):
add ocaml libs (xc/xb/xs/eventchn)
add ocaml xenstored
add compilation makefile to ocaml directory
remove hook from external ocaml repository
add ocaml tools to build if defined. default to n
default ocaml tools config variable to y
Config.mk | 15 +-
tools/Makefile | 23 +-
tools/ocaml/Makefile | 36 +
tools/ocaml/Makefile.rules | 93 ++
tools/ocaml/common.make | 28 +
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 +
tools/ocaml/xenstored/Makefile | 54 +
tools/ocaml/xenstored/config.ml | 112 ++
tools/ocaml/xenstored/connection.ml | 234 +++++
tools/ocaml/xenstored/connections.ml | 167 +++
tools/ocaml/xenstored/define.ml | 40 +
tools/ocaml/xenstored/disk.ml | 157 +++
tools/ocaml/xenstored/domain.ml | 62 ++
tools/ocaml/xenstored/domains.ml | 84 ++
tools/ocaml/xenstored/event.ml | 29 +
tools/ocaml/xenstored/logging.ml | 238 +++++
tools/ocaml/xenstored/parse_arg.ml | 68 ++
tools/ocaml/xenstored/perms.ml | 165 +++
tools/ocaml/xenstored/process.ml | 395 ++++++++
tools/ocaml/xenstored/quota.ml | 83 ++
tools/ocaml/xenstored/store.ml | 460 +++++++++
tools/ocaml/xenstored/symbol.ml | 76 ++
tools/ocaml/xenstored/symbol.mli | 52 +
tools/ocaml/xenstored/transaction.ml | 197 ++++
tools/ocaml/xenstored/utils.ml | 107 ++
tools/ocaml/xenstored/xenstored.conf | 30 +
tools/ocaml/xenstored/xenstored.ml | 404 ++++++++
tools/xenstore/Makefile | 5 -
115 files changed, 13609 insertions(+), 32 deletions(-)
create mode 100644 tools/ocaml/Makefile
create mode 100644 tools/ocaml/Makefile.rules
create mode 100644 tools/ocaml/common.make
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
create mode 100644 tools/ocaml/xenstored/Makefile
create mode 100644 tools/ocaml/xenstored/config.ml
create mode 100644 tools/ocaml/xenstored/connection.ml
create mode 100644 tools/ocaml/xenstored/connections.ml
create mode 100644 tools/ocaml/xenstored/define.ml
create mode 100644 tools/ocaml/xenstored/disk.ml
create mode 100644 tools/ocaml/xenstored/domain.ml
create mode 100644 tools/ocaml/xenstored/domains.ml
create mode 100644 tools/ocaml/xenstored/event.ml
create mode 100644 tools/ocaml/xenstored/logging.ml
create mode 100644 tools/ocaml/xenstored/parse_arg.ml
create mode 100644 tools/ocaml/xenstored/perms.ml
create mode 100644 tools/ocaml/xenstored/process.ml
create mode 100644 tools/ocaml/xenstored/quota.ml
create mode 100644 tools/ocaml/xenstored/store.ml
create mode 100644 tools/ocaml/xenstored/symbol.ml
create mode 100644 tools/ocaml/xenstored/symbol.mli
create mode 100644 tools/ocaml/xenstored/transaction.ml
create mode 100644 tools/ocaml/xenstored/utils.ml
create mode 100644 tools/ocaml/xenstored/xenstored.conf
create mode 100644 tools/ocaml/xenstored/xenstored.ml
[-- Attachment #2: Type: text/plain, Size: 138 bytes --]
_______________________________________________
Xen-devel mailing list
Xen-devel@lists.xensource.com
http://lists.xensource.com/xen-devel
^ permalink raw reply [flat|nested] 7+ messages in thread
* [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
* [PATCH 2/6] add ocaml xenstored
2010-03-01 11:59 [RFC][PATCH 0/6] merge ocaml xenstored and dependencies Vincent Hanquez
2010-03-01 11:59 ` [PATCH 1/6] add ocaml libs (xc/xb/xs/eventchn) Vincent Hanquez
@ 2010-03-01 11:59 ` Vincent Hanquez
2010-03-01 11:59 ` [PATCH 3/6] add compilation makefile to ocaml directory Vincent Hanquez
` (3 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: 2488 bytes --]
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
tools/ocaml/xenstored/Makefile | 54 ++++
tools/ocaml/xenstored/config.ml | 112 ++++++++
tools/ocaml/xenstored/connection.ml | 234 +++++++++++++++++
tools/ocaml/xenstored/connections.ml | 167 ++++++++++++
tools/ocaml/xenstored/define.ml | 40 +++
tools/ocaml/xenstored/disk.ml | 157 ++++++++++++
tools/ocaml/xenstored/domain.ml | 62 +++++
tools/ocaml/xenstored/domains.ml | 84 ++++++
tools/ocaml/xenstored/event.ml | 29 +++
tools/ocaml/xenstored/logging.ml | 238 ++++++++++++++++++
tools/ocaml/xenstored/parse_arg.ml | 68 +++++
tools/ocaml/xenstored/perms.ml | 165 ++++++++++++
tools/ocaml/xenstored/process.ml | 395 +++++++++++++++++++++++++++++
tools/ocaml/xenstored/quota.ml | 83 ++++++
tools/ocaml/xenstored/store.ml | 460 ++++++++++++++++++++++++++++++++++
tools/ocaml/xenstored/symbol.ml | 76 ++++++
tools/ocaml/xenstored/symbol.mli | 52 ++++
tools/ocaml/xenstored/transaction.ml | 197 +++++++++++++++
tools/ocaml/xenstored/utils.ml | 107 ++++++++
tools/ocaml/xenstored/xenstored.conf | 30 +++
tools/ocaml/xenstored/xenstored.ml | 404 +++++++++++++++++++++++++++++
21 files changed, 3214 insertions(+), 0 deletions(-)
create mode 100644 tools/ocaml/xenstored/Makefile
create mode 100644 tools/ocaml/xenstored/config.ml
create mode 100644 tools/ocaml/xenstored/connection.ml
create mode 100644 tools/ocaml/xenstored/connections.ml
create mode 100644 tools/ocaml/xenstored/define.ml
create mode 100644 tools/ocaml/xenstored/disk.ml
create mode 100644 tools/ocaml/xenstored/domain.ml
create mode 100644 tools/ocaml/xenstored/domains.ml
create mode 100644 tools/ocaml/xenstored/event.ml
create mode 100644 tools/ocaml/xenstored/logging.ml
create mode 100644 tools/ocaml/xenstored/parse_arg.ml
create mode 100644 tools/ocaml/xenstored/perms.ml
create mode 100644 tools/ocaml/xenstored/process.ml
create mode 100644 tools/ocaml/xenstored/quota.ml
create mode 100644 tools/ocaml/xenstored/store.ml
create mode 100644 tools/ocaml/xenstored/symbol.ml
create mode 100644 tools/ocaml/xenstored/symbol.mli
create mode 100644 tools/ocaml/xenstored/transaction.ml
create mode 100644 tools/ocaml/xenstored/utils.ml
create mode 100644 tools/ocaml/xenstored/xenstored.conf
create mode 100644 tools/ocaml/xenstored/xenstored.ml
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0002-add-ocaml-xenstored.patch --]
[-- Type: text/x-patch; name="0002-add-ocaml-xenstored.patch", Size: 108196 bytes --]
diff --git a/tools/ocaml/xenstored/Makefile b/tools/ocaml/xenstored/Makefile
new file mode 100644
index 0000000..0e7cce4
--- /dev/null
+++ b/tools/ocaml/xenstored/Makefile
@@ -0,0 +1,54 @@
+OCAML_TOPLEVEL = ..
+include $(OCAML_TOPLEVEL)/common.make
+
+OCAMLINCLUDE += \
+ -I $(OCAML_TOPLEVEL)/libs/log \
+ -I $(OCAML_TOPLEVEL)/libs/xb \
+ -I $(OCAML_TOPLEVEL)/libs/uuid \
+ -I $(OCAML_TOPLEVEL)/libs/mmap \
+ -I $(OCAML_TOPLEVEL)/libs/xc \
+ -I $(OCAML_TOPLEVEL)/libs/eventchn \
+ -I $(OCAML_TOPLEVEL)/libs/stdext
+
+OBJS = define \
+ config \
+ logging \
+ quota \
+ perms \
+ symbol \
+ utils \
+ store \
+ disk \
+ transaction \
+ event \
+ domain \
+ domains \
+ connection \
+ connections \
+ parse_arg \
+ process \
+ xenstored
+
+INTF = symbol.cmi
+XENSTOREDLIBS = \
+ unix.cmxa \
+ $(OCAML_TOPLEVEL)/libs/uuid/uuid.cmxa \
+ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap $(OCAML_TOPLEVEL)/libs/mmap/mmap.cmxa \
+ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/log $(OCAML_TOPLEVEL)/libs/log/log.cmxa \
+ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn $(OCAML_TOPLEVEL)/libs/eventchn/eventchn.cmxa \
+ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xc $(OCAML_TOPLEVEL)/libs/xc/xc.cmxa \
+ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xb $(OCAML_TOPLEVEL)/libs/xb/xb.cmxa \
+ -ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/stdext $(OCAML_TOPLEVEL)/libs/stdext/stdext.cmxa
+
+PROGRAMS = oxenstored
+
+oxenstored_LIBS = $(XENSTOREDLIBS)
+oxenstored_OBJS = $(OBJS)
+
+OCAML_PROGRAM = oxenstored
+
+all: $(INTF) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+include $(OCAML_TOPLEVEL)/Makefile.rules
diff --git a/tools/ocaml/xenstored/config.ml b/tools/ocaml/xenstored/config.ml
new file mode 100644
index 0000000..0ee7bc3
--- /dev/null
+++ b/tools/ocaml/xenstored/config.ml
@@ -0,0 +1,112 @@
+(*
+ * 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 ty =
+ | Set_bool of bool ref
+ | Set_int of int ref
+ | Set_string of string ref
+ | Set_float of float ref
+ | Unit of (unit -> unit)
+ | Bool of (bool -> unit)
+ | Int of (int -> unit)
+ | String of (string -> unit)
+ | Float of (float -> unit)
+
+exception Error of (string * string) list
+
+let trim_start lc s =
+ let len = String.length s and i = ref 0 in
+ while !i < len && (List.mem s.[!i] lc)
+ do
+ incr i
+ done;
+ if !i < len then String.sub s !i (len - !i) else ""
+
+let trim_end lc s =
+ let i = ref (String.length s - 1) in
+ while !i > 0 && (List.mem s.[!i] lc)
+ do
+ decr i
+ done;
+ if !i >= 0 then String.sub s 0 (!i + 1) else ""
+
+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 parse_line stream =
+ let lc = [ ' '; '\t' ] in
+ let trim_spaces s = trim_end lc (trim_start lc s) in
+ let to_config s =
+ match split ~limit:2 '=' s with
+ | k :: v :: [] -> Some (trim_end lc k, trim_start lc v)
+ | _ -> None in
+ let rec read_filter_line () =
+ try
+ let line = trim_spaces (input_line stream) in
+ if String.length line > 0 && line.[0] <> '#' then
+ match to_config line with
+ | None -> read_filter_line ()
+ | Some x -> x :: read_filter_line ()
+ else
+ read_filter_line ()
+ with
+ End_of_file -> [] in
+ read_filter_line ()
+
+let parse filename =
+ let stream = open_in filename in
+ let cf = parse_line stream in
+ close_in stream;
+ cf
+
+let validate cf expected other =
+ let err = ref [] in
+ let append x = err := x :: !err in
+ List.iter (fun (k, v) ->
+ try
+ if not (List.mem_assoc k expected) then
+ other k v
+ else let ty = List.assoc k expected in
+ match ty with
+ | Unit f -> f ()
+ | Bool f -> f (bool_of_string v)
+ | String f -> f v
+ | Int f -> f (int_of_string v)
+ | Float f -> f (float_of_string v)
+ | Set_bool r -> r := (bool_of_string v)
+ | Set_string r -> r := v
+ | Set_int r -> r := int_of_string v
+ | Set_float r -> r := (float_of_string v)
+ with
+ | Not_found -> append (k, "unknown key")
+ | Failure "int_of_string" -> append (k, "expect int arg")
+ | Failure "bool_of_string" -> append (k, "expect bool arg")
+ | Failure "float_of_string" -> append (k, "expect float arg")
+ | exn -> append (k, Printexc.to_string exn)
+ ) cf;
+ if !err != [] then raise (Error !err)
+
+(** read a filename, parse and validate, and return the errors if any *)
+let read filename expected other =
+ let cf = parse filename in
+ validate cf expected other
diff --git a/tools/ocaml/xenstored/connection.ml b/tools/ocaml/xenstored/connection.ml
new file mode 100644
index 0000000..9da9e7c
--- /dev/null
+++ b/tools/ocaml/xenstored/connection.ml
@@ -0,0 +1,234 @@
+(*
+ * 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 End_of_file
+
+open Stringext
+
+type watch = {
+ con: t;
+ token: string;
+ path: string;
+ base: string;
+ is_relative: bool;
+}
+
+and t = {
+ xb: Xb.t;
+ dom: Domain.t option;
+ transactions: (int, Transaction.t) Hashtbl.t;
+ mutable next_tid: int;
+ watches: (string, watch list) Hashtbl.t;
+ mutable nb_watches: int;
+ anonid: int;
+ mutable stat_nb_ops: int;
+ mutable perm: Perms.Connection.t;
+}
+
+let get_path con =
+Printf.sprintf "/local/domain/%i/" (match con.dom with None -> 0 | Some d -> Domain.get_id d)
+
+let watch_create ~con ~path ~token = {
+ con = con;
+ token = token;
+ path = path;
+ base = get_path con;
+ is_relative = path.[0] <> '/' && path.[0] <> '@'
+}
+
+let get_con w = w.con
+
+let number_of_transactions con =
+ Hashtbl.length con.transactions
+
+let get_domain con = con.dom
+
+let anon_id_next = ref 1
+
+let get_domstr con =
+ match con.dom with
+ | None -> "A" ^ (string_of_int con.anonid)
+ | Some dom -> "D" ^ (string_of_int (Domain.get_id dom))
+
+let make_perm dom =
+ let domid =
+ match dom with
+ | None -> 0
+ | Some d -> Domain.get_id d
+ in
+ Perms.Connection.create ~perms:[Perms.READ; Perms.WRITE] domid
+
+let create xbcon dom =
+ let id =
+ match dom with
+ | None -> let old = !anon_id_next in incr anon_id_next; old
+ | Some _ -> 0
+ in
+ let con =
+ {
+ xb = xbcon;
+ dom = dom;
+ transactions = Hashtbl.create 5;
+ next_tid = 1;
+ watches = Hashtbl.create 8;
+ nb_watches = 0;
+ anonid = id;
+ stat_nb_ops = 0;
+ perm = make_perm dom;
+ }
+ in
+ Logging.new_connection ~tid:Transaction.none ~con:(get_domstr con);
+ con
+
+let get_fd con = Xb.get_fd con.xb
+let close con =
+ Logging.end_connection ~tid:Transaction.none ~con:(get_domstr con);
+ Xb.close con.xb
+
+let get_perm con =
+ con.perm
+
+let restrict con domid =
+ con.perm <- Perms.Connection.restrict con.perm domid
+
+let set_target con target_domid =
+ con.perm <- Perms.Connection.set_target (get_perm con) ~perms:[Perms.READ; Perms.WRITE] target_domid
+
+let send_reply con tid rid ty data =
+ Xb.queue con.xb (Xb.Packet.create tid rid ty data)
+
+let send_error con tid rid err = send_reply con tid rid Xb.Op.Error (err ^ "\000")
+let send_ack con tid rid ty = send_reply con tid rid ty "OK\000"
+
+let get_watch_path con path =
+ if path.[0] = '@' || path.[0] = '/' then
+ path
+ else
+ let rpath = get_path con in
+ rpath ^ path
+
+let get_watches (con: t) path =
+ if Hashtbl.mem con.watches path
+ then Hashtbl.find con.watches path
+ else []
+
+let get_children_watches con path =
+ let path = path ^ "/" in
+ List.concat (Hashtbl.fold (fun p w l ->
+ if String.startswith path p then w :: l else l) con.watches [])
+
+let is_dom0 con =
+ Perms.Connection.is_dom0 (get_perm con)
+
+let add_watch con path token =
+ if !Quota.activate && !Define.maxwatch > 0 &&
+ not (is_dom0 con) && con.nb_watches > !Define.maxwatch then
+ raise Quota.Limit_reached;
+ let apath = get_watch_path con path in
+ let l = get_watches con apath in
+ if List.exists (fun w -> w.token = token) l then
+ raise Define.Already_exist;
+ let watch = watch_create ~con ~token ~path in
+ Hashtbl.replace con.watches apath (watch :: l);
+ con.nb_watches <- con.nb_watches + 1;
+ apath, watch
+
+let del_watch con path token =
+ let apath = get_watch_path con path in
+ let ws = Hashtbl.find con.watches apath in
+ let w = List.find (fun w -> w.token = token) ws in
+ let filtered = Utils.list_remove w ws in
+ if List.length filtered > 0 then
+ Hashtbl.replace con.watches apath filtered
+ else
+ Hashtbl.remove con.watches apath;
+ con.nb_watches <- con.nb_watches - 1;
+ apath, w
+
+let list_watches con =
+ let ll = Hashtbl.fold
+ (fun _ watches acc -> List.map (fun watch -> watch.path, watch.token) watches :: acc)
+ con.watches [] in
+ List.concat ll
+
+let fire_single_watch watch =
+ let data = Utils.join_by_null [watch.path; watch.token; ""] in
+ send_reply watch.con Transaction.none 0 Xb.Op.Watchevent data
+
+let fire_watch watch path =
+ let new_path =
+ if watch.is_relative && path.[0] = '/'
+ then begin
+ let n = String.length watch.base
+ and m = String.length path in
+ String.sub path n (m - n)
+ end else
+ path
+ in
+ let data = Utils.join_by_null [ new_path; watch.token; "" ] in
+ send_reply watch.con Transaction.none 0 Xb.Op.Watchevent data
+
+let find_next_tid con =
+ let ret = con.next_tid in con.next_tid <- con.next_tid + 1; ret
+
+let start_transaction con store =
+ if !Define.maxtransaction > 0 && not (is_dom0 con)
+ && Hashtbl.length con.transactions > !Define.maxtransaction then
+ raise Quota.Transaction_opened;
+ let id = find_next_tid con in
+ let ntrans = Transaction.make id store in
+ Hashtbl.add con.transactions id ntrans;
+ Logging.start_transaction ~tid:id ~con:(get_domstr con);
+ id
+
+let end_transaction con tid commit =
+ let trans = Hashtbl.find con.transactions tid in
+ Hashtbl.remove con.transactions tid;
+ Logging.end_transaction ~tid ~con:(get_domstr con);
+ if commit then Transaction.commit ~con:(get_domstr con) trans else true
+
+let get_transaction con tid =
+ Hashtbl.find con.transactions tid
+
+let do_input con = Xb.input con.xb
+let has_input con = Xb.has_in_packet con.xb
+let pop_in con = Xb.get_in_packet con.xb
+let has_more_input con = Xb.has_more_input con.xb
+
+let has_output con = Xb.has_output con.xb
+let has_new_output con = Xb.has_new_output con.xb
+let peek_output con = Xb.peek_output con.xb
+let do_output con = Xb.output con.xb
+
+let incr_ops con = con.stat_nb_ops <- con.stat_nb_ops + 1
+
+let mark_symbols con =
+ Hashtbl.iter (fun _ t -> Store.mark_symbols (Transaction.get_store t)) con.transactions
+
+let stats con =
+ Hashtbl.length con.watches, con.stat_nb_ops
+
+let dump con chan =
+ match con.dom with
+ | Some dom ->
+ let domid = Domain.get_id dom in
+ (* dump domain *)
+ Domain.dump dom chan;
+ (* dump watches *)
+ List.iter (fun (path, token) ->
+ Printf.fprintf chan "watch,%d,%s,%s\n" domid (Utils.hexify path) (Utils.hexify token)
+ ) (list_watches con);
+ | None -> ()
diff --git a/tools/ocaml/xenstored/connections.ml b/tools/ocaml/xenstored/connections.ml
new file mode 100644
index 0000000..c331bab
--- /dev/null
+++ b/tools/ocaml/xenstored/connections.ml
@@ -0,0 +1,167 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * 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.
+ *)
+
+let debug fmt = Logs.debug "general" fmt
+
+type t = {
+ mutable anonymous: Connection.t list;
+ domains: (int, Connection.t) Hashtbl.t;
+ mutable watches: (string, Connection.watch list) Trie.t;
+}
+
+let create () = { anonymous = []; domains = Hashtbl.create 8; watches = Trie.create () }
+
+let add_anonymous cons fd can_write =
+ let xbcon = Xb.open_fd fd in
+ let con = Connection.create xbcon None in
+ cons.anonymous <- con :: cons.anonymous
+
+let add_domain cons dom =
+ let xbcon = Xb.open_mmap (Domain.get_interface dom) (fun () -> Domain.notify dom) in
+ let con = Connection.create xbcon (Some dom) in
+ Hashtbl.add cons.domains (Domain.get_id dom) con
+
+let select cons =
+ let inset = List.map (fun c -> Connection.get_fd c) cons.anonymous
+ and outset = List.fold_left (fun l c -> if Connection.has_output c
+ then Connection.get_fd c :: l
+ else l) [] cons.anonymous in
+ inset, outset
+
+let find cons fd =
+ List.find (fun c -> Connection.get_fd c = fd) cons.anonymous
+
+let find_domain cons id =
+ Hashtbl.find cons.domains id
+
+let del_watches_of_con con watches =
+ match List.filter (fun w -> Connection.get_con w != con) watches with
+ | [] -> None
+ | ws -> Some ws
+
+let del_anonymous cons con =
+ try
+ cons.anonymous <- Utils.list_remove con cons.anonymous;
+ cons.watches <- Trie.map (del_watches_of_con con) cons.watches;
+ Connection.close con
+ with exn ->
+ debug "del anonymous %s" (Printexc.to_string exn)
+
+let del_domain cons id =
+ try
+ let con = find_domain cons id in
+ Hashtbl.remove cons.domains id;
+ cons.watches <- Trie.map (del_watches_of_con con) cons.watches;
+ Connection.close con
+ with exn ->
+ debug "del domain %u: %s" id (Printexc.to_string exn)
+
+let iter_domains cons fct =
+ Hashtbl.iter (fun k c -> fct c) cons.domains
+
+let iter_anonymous cons fct =
+ List.iter (fun c -> fct c) (List.rev cons.anonymous)
+
+let iter cons fct =
+ iter_domains cons fct; iter_anonymous cons fct
+
+let has_more_work cons =
+ Hashtbl.fold (fun id con acc ->
+ if Connection.has_more_input con then
+ con :: acc
+ else
+ acc) cons.domains []
+
+let key_of_str path =
+ if path.[0] = '@'
+ then [path]
+ else "" :: Store.Path.to_string_list (Store.Path.of_string path)
+
+let key_of_path path =
+ "" :: Store.Path.to_string_list path
+
+let add_watch cons con path token =
+ let apath, watch = Connection.add_watch con path token in
+ let key = key_of_str apath in
+ let watches =
+ if Trie.mem cons.watches key
+ then Trie.find cons.watches key
+ else []
+ in
+ cons.watches <- Trie.set cons.watches key (watch :: watches);
+ watch
+
+let del_watch cons con path token =
+ let apath, watch = Connection.del_watch con path token in
+ let key = key_of_str apath in
+ let watches = Utils.list_remove watch (Trie.find cons.watches key) in
+ if watches = [] then
+ cons.watches <- Trie.unset cons.watches key
+ else
+ cons.watches <- Trie.set cons.watches key watches;
+ watch
+
+(* path is absolute *)
+let fire_watches cons path recurse =
+ let key = key_of_path path in
+ let path = Store.Path.to_string path in
+ let fire_watch _ = function
+ | None -> ()
+ | Some watches -> List.iter (fun w -> Connection.fire_watch w path) watches
+ in
+ let fire_rec x = function
+ | None -> ()
+ | Some watches ->
+ List.iter (fun w -> Connection.fire_single_watch w) watches
+ in
+ Trie.iter_path fire_watch cons.watches key;
+ if recurse then
+ Trie.iter fire_rec (Trie.sub cons.watches key)
+
+let fire_spec_watches cons specpath =
+ iter cons (fun con ->
+ List.iter (fun w -> Connection.fire_single_watch w) (Connection.get_watches con specpath))
+
+let set_target cons domain target_domain =
+ let con = find_domain cons domain in
+ Connection.set_target con target_domain
+
+let number_of_transactions cons =
+ let res = ref 0 in
+ let aux con =
+ res := Connection.number_of_transactions con + !res
+ in
+ iter cons aux;
+ !res
+
+let stats cons =
+ let nb_ops_anon = ref 0
+ and nb_watchs_anon = ref 0
+ and nb_ops_dom = ref 0
+ and nb_watchs_dom = ref 0 in
+ iter_anonymous cons (fun con ->
+ let con_watchs, con_ops = Connection.stats con in
+ nb_ops_anon := !nb_ops_anon + con_ops;
+ nb_watchs_anon := !nb_watchs_anon + con_watchs;
+ );
+ iter_domains cons (fun con ->
+ let con_watchs, con_ops = Connection.stats con in
+ nb_ops_dom := !nb_ops_dom + con_ops;
+ nb_watchs_dom := !nb_watchs_dom + con_watchs;
+ );
+ (List.length cons.anonymous, !nb_ops_anon, !nb_watchs_anon,
+ Hashtbl.length cons.domains, !nb_ops_dom, !nb_watchs_dom)
diff --git a/tools/ocaml/xenstored/define.ml b/tools/ocaml/xenstored/define.ml
new file mode 100644
index 0000000..19a699f
--- /dev/null
+++ b/tools/ocaml/xenstored/define.ml
@@ -0,0 +1,40 @@
+(*
+ * 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 xenstored_major = 1
+let xenstored_minor = 0
+
+let xenstored_proc_kva = "/proc/xen/xsd_kva"
+let xenstored_proc_port = "/proc/xen/xsd_port"
+
+let xs_daemon_socket = "/var/run/xenstored/socket"
+let xs_daemon_socket_ro = "/var/run/xenstored/socket_ro"
+
+let default_config_dir = "/etc/xensource"
+
+let maxwatch = ref (50)
+let maxtransaction = ref (20)
+
+let domid_self = 0x7FF0
+
+exception Not_a_directory of string
+exception Not_a_value of string
+exception Already_exist
+exception Doesnt_exist
+exception Lookup_Doesnt_exist of string
+exception Invalid_path
+exception Permission_denied
+exception Unknown_operation
diff --git a/tools/ocaml/xenstored/disk.ml b/tools/ocaml/xenstored/disk.ml
new file mode 100644
index 0000000..65dd42a
--- /dev/null
+++ b/tools/ocaml/xenstored/disk.ml
@@ -0,0 +1,157 @@
+(*
+ * 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 enable = ref false
+let xs_daemon_database = "/var/run/xenstored/db"
+
+let error = Logs.error "general"
+
+(* unescape utils *)
+exception Bad_escape
+
+let is_digit c = match c with '0' .. '9' -> true | _ -> false
+
+let undec c =
+ match c with
+ | '0' .. '9' -> (Char.code c) - (Char.code '0')
+ | _ -> raise (Failure "undecify")
+
+let unhex c =
+ let c = Char.lowercase c in
+ match c with
+ | '0' .. '9' -> (Char.code c) - (Char.code '0')
+ | 'a' .. 'f' -> (Char.code c) - (Char.code 'a') + 10
+ | _ -> raise (Failure "unhexify")
+
+let string_unescaped s =
+ let len = String.length s
+ and i = ref 0 in
+ let d = Buffer.create len in
+
+ let read_escape () =
+ incr i;
+ match s.[!i] with
+ | 'n' -> '\n'
+ | 'r' -> '\r'
+ | '\\' -> '\\'
+ | '\'' -> '\''
+ | '"' -> '"'
+ | 't' -> '\t'
+ | 'b' -> '\b'
+ | 'x' ->
+ let v = (unhex s.[!i + 1] * 16) + unhex s.[!i + 2] in
+ i := !i + 2;
+ Char.chr v
+ | c ->
+ if is_digit c then (
+ let v = (undec s.[!i]) * 100 +
+ (undec s.[!i + 1]) * 10 +
+ (undec s.[!i + 2]) in
+ i := !i + 2;
+ Char.chr v
+ ) else
+ raise Bad_escape
+ in
+
+ while !i < len
+ do
+ let c = match s.[!i] with
+ | '\\' -> read_escape ()
+ | c -> c in
+ Buffer.add_char d c;
+ incr i
+ done;
+ Buffer.contents d
+
+(* file -> lines_of_file *)
+let file_readlines file =
+ let channel = open_in file in
+ let rec input_line_list channel =
+ let line = try input_line channel with End_of_file -> "" in
+ if String.length line > 0 then
+ line :: input_line_list channel
+ else (
+ close_in channel;
+ []
+ ) in
+ input_line_list channel
+
+let rec map_string_list_range l s =
+ match l with
+ | [] -> []
+ | (a,b) :: l -> String.sub s a (b - a) :: map_string_list_range l s
+
+let is_digit c =
+ try ignore (int_of_char c); true with _ -> false
+
+let rec parse_perm s =
+ let len = String.length s in
+ if len = 0 then
+ []
+ else
+ let i = ref 1 in
+ while !i < len && is_digit s.[!i] do incr i done;
+ let x = String.sub s 0 !i
+ and lx = String.sub s !i len in
+ x :: parse_perm lx
+
+let read store =
+ (* don't let the permission get on our way, full perm ! *)
+ let v = Store.get_ops store Perms.Connection.full_rights in
+
+ (* a line is : path{perm} or path{perm} = value *)
+ let parse_line s =
+ let path, perm, value =
+ let len = String.length s in
+ let si = if String.contains s '=' then
+ String.index s '='
+ else
+ len - 1 in
+ let pi = String.rindex_from s si '{' in
+ let epi = String.index_from s pi '}' in
+
+ if String.contains s '=' then
+ let ss = map_string_list_range [ (0, pi);
+ (pi + 1, epi);
+ (si + 2, len); ] s in
+ (List.nth ss 0, List.nth ss 1, List.nth ss 2)
+ else
+ let ss = map_string_list_range [ (0, pi);
+ (pi + 1, epi);
+ ] s in
+ (List.nth ss 0, List.nth ss 1, "")
+ in
+ let path = Store.Path.of_string path in
+ v.Store.write path (string_unescaped value);
+ v.Store.setperms path (Perms.Node.of_strings (parse_perm perm)) in
+ try
+ let lines = file_readlines xs_daemon_database in
+ List.iter (fun s -> parse_line s) lines
+ with exc ->
+ error "caught exn %s" (Printexc.to_string exc)
+
+let write store =
+ if !enable then
+ try
+ let tfile = Printf.sprintf "%s#" xs_daemon_database in
+ let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ]
+ 0o600 tfile in
+ Store.dump store channel;
+ flush channel;
+ close_out channel;
+ Unix.rename tfile xs_daemon_database
+ with exc ->
+ error "caught exn %s" (Printexc.to_string exc)
diff --git a/tools/ocaml/xenstored/domain.ml b/tools/ocaml/xenstored/domain.ml
new file mode 100644
index 0000000..258d172
--- /dev/null
+++ b/tools/ocaml/xenstored/domain.ml
@@ -0,0 +1,62 @@
+(*
+ * 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
+
+let debug fmt = Logs.debug "general" fmt
+
+type t =
+{
+ id: Xc.domid;
+ mfn: nativeint;
+ remote_port: int;
+ interface: Mmap.mmap_interface;
+ eventchn: Event.t;
+ mutable port: int;
+}
+
+let get_path dom = "/local/domain/" ^ (sprintf "%u" dom.id)
+let get_id domain = domain.id
+let get_interface d = d.interface
+let get_mfn d = d.mfn
+let get_remote_port d = d.remote_port
+
+let dump d chan =
+ fprintf chan "dom,%d,%nd,%d\n" d.id d.mfn d.port
+
+let notify dom = Event.notify dom.eventchn dom.port; ()
+
+let bind_interdomain dom =
+ dom.port <- Event.bind_interdomain dom.eventchn dom.id dom.remote_port;
+ debug "domain %d bound port %d" dom.id dom.port
+
+
+let close dom =
+ debug "domain %d unbound port %d" dom.id dom.port;
+ Event.unbind dom.eventchn dom.port;
+ Mmap.unmap dom.interface;
+ ()
+
+let make id mfn remote_port interface eventchn = {
+ id = id;
+ mfn = mfn;
+ remote_port = remote_port;
+ interface = interface;
+ eventchn = eventchn;
+ port = -1
+}
+
+let is_dom0 d = d.id = 0
diff --git a/tools/ocaml/xenstored/domains.ml b/tools/ocaml/xenstored/domains.ml
new file mode 100644
index 0000000..54d50d8
--- /dev/null
+++ b/tools/ocaml/xenstored/domains.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 domains = {
+ eventchn: Event.t;
+ table: (Xc.domid, Domain.t) Hashtbl.t;
+}
+
+let init eventchn =
+ { eventchn = eventchn; table = Hashtbl.create 10 }
+let del doms id = Hashtbl.remove doms.table id
+let exist doms id = Hashtbl.mem doms.table id
+let find doms id = Hashtbl.find doms.table id
+let number doms = Hashtbl.length doms.table
+let iter doms fct = Hashtbl.iter (fun _ b -> fct b) doms.table
+
+let cleanup xc doms =
+ let notify = ref false in
+ let dead_dom = ref [] in
+
+ Hashtbl.iter (fun id _ -> if id <> 0 then
+ try
+ let info = Xc.domain_getinfo xc id in
+ if info.Xc.shutdown || info.Xc.dying then (
+ Logs.debug "general" "Domain %u died (dying=%b, shutdown %b -- code %d)"
+ id info.Xc.dying info.Xc.shutdown info.Xc.shutdown_code;
+ if info.Xc.dying then
+ dead_dom := id :: !dead_dom
+ else
+ notify := true;
+ )
+ with Xc.Error _ ->
+ Logs.debug "general" "Domain %u died -- no domain info" id;
+ dead_dom := id :: !dead_dom;
+ ) doms.table;
+ List.iter (fun id ->
+ let dom = Hashtbl.find doms.table id in
+ Domain.close dom;
+ Hashtbl.remove doms.table id;
+ ) !dead_dom;
+ !notify, !dead_dom
+
+let resume doms domid =
+ ()
+
+let create xc doms domid mfn port =
+ let interface = Xc.map_foreign_range xc domid (Mmap.getpagesize()) mfn in
+ let dom = Domain.make domid mfn port interface doms.eventchn in
+ Hashtbl.add doms.table domid dom;
+ Domain.bind_interdomain dom;
+ dom
+
+let create0 fake doms =
+ let port, interface =
+ if fake then (
+ 0, Xc.with_intf (fun xc -> Xc.map_foreign_range xc 0 (Mmap.getpagesize()) 0n)
+ ) else (
+ let port = Utils.read_file_single_integer Define.xenstored_proc_port
+ and fd = Unix.openfile Define.xenstored_proc_kva
+ [ Unix.O_RDWR ] 0o600 in
+ let interface = Mmap.mmap fd Mmap.RDWR Mmap.SHARED
+ (Mmap.getpagesize()) 0 in
+ Unix.close fd;
+ port, interface
+ )
+ in
+ let dom = Domain.make 0 Nativeint.zero port interface doms.eventchn in
+ Hashtbl.add doms.table 0 dom;
+ Domain.bind_interdomain dom;
+ Domain.notify dom;
+ dom
diff --git a/tools/ocaml/xenstored/event.ml b/tools/ocaml/xenstored/event.ml
new file mode 100644
index 0000000..5cbdccf
--- /dev/null
+++ b/tools/ocaml/xenstored/event.ml
@@ -0,0 +1,29 @@
+(*
+ * 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.
+ *)
+
+(**************** high level binding ****************)
+type t = {
+ fd: Unix.file_descr;
+ mutable virq_port: int;
+}
+
+let init () = { fd = Eventchn.init (); virq_port = -1; }
+let bind_virq eventchn = eventchn.virq_port <- Eventchn.bind_virq eventchn.fd
+let bind_interdomain eventchn domid port = Eventchn.bind_interdomain eventchn.fd domid port
+let unbind eventchn port = Eventchn.unbind eventchn.fd port
+let notify eventchn port = Eventchn.notify eventchn.fd port
+let read_port eventchn = Eventchn.read_port eventchn.fd
+let write_port eventchn port = Eventchn.write_port eventchn.fd port
diff --git a/tools/ocaml/xenstored/logging.ml b/tools/ocaml/xenstored/logging.ml
new file mode 100644
index 0000000..639ac2a
--- /dev/null
+++ b/tools/ocaml/xenstored/logging.ml
@@ -0,0 +1,238 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@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
+
+let error fmt = Logs.error "general" fmt
+let info fmt = Logs.info "general" fmt
+let debug fmt = Logs.debug "general" fmt
+
+let access_log_file = ref "/var/log/xenstored-access.log"
+let access_log_nb_files = ref 20
+let access_log_nb_lines = ref 13215
+let activate_access_log = ref true
+
+(* maximal size of the lines in xenstore-acces.log file *)
+let line_size = 180
+
+let log_read_ops = ref false
+let log_transaction_ops = ref false
+let log_special_ops = ref false
+
+type access_type =
+ | Coalesce
+ | Conflict
+ | Commit
+ | Newconn
+ | Endconn
+ | XbOp of Xb.Op.operation
+
+type access =
+ {
+ fd: out_channel ref;
+ counter: int ref;
+ write: tid:int -> con:string -> ?data:string -> access_type -> unit;
+ }
+
+let string_of_date () =
+ 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 fill_with_space n s =
+ if String.length s < n
+ then
+ let r = String.make n ' ' in
+ String.blit s 0 r 0 (String.length s);
+ r
+ else
+ s
+
+let string_of_tid ~con tid =
+ if tid = 0
+ then fill_with_space 12 (sprintf "%s" con)
+ else fill_with_space 12 (sprintf "%s.%i" con tid)
+
+let string_of_access_type = function
+ | Coalesce -> "coalesce "
+ | Conflict -> "conflict "
+ | Commit -> "commit "
+ | Newconn -> "newconn "
+ | Endconn -> "endconn "
+
+ | XbOp op -> match op with
+ | Xb.Op.Debug -> "debug "
+
+ | Xb.Op.Directory -> "directory"
+ | Xb.Op.Read -> "read "
+ | Xb.Op.Getperms -> "getperms "
+
+ | Xb.Op.Watch -> "watch "
+ | Xb.Op.Unwatch -> "unwatch "
+
+ | Xb.Op.Transaction_start -> "t start "
+ | Xb.Op.Transaction_end -> "t end "
+
+ | Xb.Op.Introduce -> "introduce"
+ | Xb.Op.Release -> "release "
+ | Xb.Op.Getdomainpath -> "getdomain"
+ | Xb.Op.Isintroduced -> "is introduced"
+ | Xb.Op.Resume -> "resume "
+
+ | Xb.Op.Write -> "write "
+ | Xb.Op.Mkdir -> "mkdir "
+ | Xb.Op.Rm -> "rm "
+ | Xb.Op.Setperms -> "setperms "
+ | Xb.Op.Restrict -> "restrict "
+ | Xb.Op.Set_target -> "settarget"
+
+ | Xb.Op.Error -> "error "
+ | Xb.Op.Watchevent -> "w event "
+
+ | x -> Xb.Op.to_string x
+
+let file_exists file =
+ try
+ Unix.close (Unix.openfile file [Unix.O_RDONLY] 0o644);
+ true
+ with _ ->
+ false
+
+let log_rotate fd =
+ let file n = sprintf "%s.%i" !access_log_file n in
+ let log_files =
+ let rec aux accu n =
+ if n >= !access_log_nb_files
+ then accu
+ else if n = 1 && file_exists !access_log_file
+ then aux [!access_log_file,1] 2
+ else
+ let file = file (n-1) in
+ if file_exists file
+ then aux ((file,n) :: accu) (n+1)
+ else accu
+ in
+ aux [] 1
+ in
+ let rec rename = function
+ | (f,n) :: t when n < !access_log_nb_files ->
+ Unix.rename f (file n);
+ rename t
+ | _ -> ()
+ in
+ rename log_files;
+ close_out !fd;
+ fd := open_out !access_log_file
+
+let sanitize_data data =
+ let data = String.copy data in
+ for i = 0 to String.length data - 1
+ do
+ if data.[i] = '\000' then
+ data.[i] <- ' '
+ done;
+ String.escaped data
+
+let make save_to_disk =
+ let fd = ref (open_out_gen [Open_append; Open_creat] 0o644 !access_log_file) in
+ let counter = ref 0 in
+ {
+ fd = fd;
+ counter = counter;
+ write =
+ if not !activate_access_log || !access_log_nb_files = 0
+ then begin fun ~tid ~con ?data _ -> () end
+ else fun ~tid ~con ?(data="") access_type ->
+ let s = Printf.sprintf "[%s] %s %s %s\n" (string_of_date()) (string_of_tid ~con tid)
+ (string_of_access_type access_type) (sanitize_data data) in
+ let s =
+ if String.length s > line_size
+ then begin
+ let s = String.sub s 0 line_size in
+ s.[line_size-3] <- '.';
+ s.[line_size-2] <- '.';
+ s.[line_size-1] <- '\n';
+ s
+ end else
+ s
+ in
+ incr counter;
+ output_string !fd s;
+ flush !fd;
+ if !counter > !access_log_nb_lines
+ then begin
+ log_rotate fd;
+ save_to_disk ();
+ counter := 0;
+ end
+ }
+
+let access : (access option) ref = ref None
+let init aal save_to_disk =
+ activate_access_log := aal;
+ access := Some (make save_to_disk)
+
+let write_access_log ~con ~tid ?data access_type =
+ try
+ Pervasiveext.maybe (fun a -> a.write access_type ~con ~tid ?data) !access
+ with _ -> ()
+
+let new_connection = write_access_log Newconn
+let end_connection = write_access_log Endconn
+let read_coalesce ~tid ~con data =
+ if !log_read_ops
+ then write_access_log Coalesce ~tid ~con ~data:("read "^data)
+let write_coalesce data = write_access_log Coalesce ~data:("write "^data)
+let conflict = write_access_log Conflict
+let commit = write_access_log Commit
+
+let xb_op ~tid ~con ~ty data =
+ let print =
+ match ty with
+ | Xb.Op.Read | Xb.Op.Directory | Xb.Op.Getperms -> !log_read_ops
+ | Xb.Op.Transaction_start | Xb.Op.Transaction_end ->
+ false (* transactions are managed below *)
+ | Xb.Op.Introduce | Xb.Op.Release | Xb.Op.Getdomainpath | Xb.Op.Isintroduced | Xb.Op.Resume ->
+ !log_special_ops
+ | _ -> true
+ in
+ if print
+ then write_access_log ~tid ~con ~data (XbOp ty)
+
+let start_transaction ~tid ~con =
+ if !log_transaction_ops && tid <> 0
+ then write_access_log ~tid ~con (XbOp Xb.Op.Transaction_start)
+
+let end_transaction ~tid ~con =
+ if !log_transaction_ops && tid <> 0
+ then write_access_log ~tid ~con (XbOp Xb.Op.Transaction_end)
+
+let xb_answer ~tid ~con ~ty data =
+ let print = match ty with
+ | Xb.Op.Error when data="ENOENT " -> !log_read_ops
+ | Xb.Op.Error -> !log_special_ops
+ | Xb.Op.Watchevent -> true
+ | _ -> false
+ in
+ if print
+ then write_access_log ~tid ~con ~data (XbOp ty)
diff --git a/tools/ocaml/xenstored/parse_arg.ml b/tools/ocaml/xenstored/parse_arg.ml
new file mode 100644
index 0000000..5d21601
--- /dev/null
+++ b/tools/ocaml/xenstored/parse_arg.ml
@@ -0,0 +1,68 @@
+(*
+ * 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 config =
+{
+ domain_init: bool;
+ activate_access_log: bool;
+ daemonize: bool;
+ reraise_top_level: bool;
+ config_file: string option;
+ pidfile: string option; (* old xenstored compatibility *)
+ tracefile: string option; (* old xenstored compatibility *)
+ restart: bool;
+ disable_socket: bool;
+}
+
+let do_argv =
+ let pidfile = ref "" and tracefile = ref "" (* old xenstored compatibility *)
+ and domain_init = ref true
+ and activate_access_log = ref true
+ and daemonize = ref true
+ and reraise_top_level = ref false
+ and config_file = ref ""
+ and restart = ref false
+ and disable_socket = ref false in
+
+ let speclist =
+ [ ("--no-domain-init", Arg.Unit (fun () -> domain_init := false),
+ "to state that xenstored should not initialise dom0");
+ ("--config-file", Arg.Set_string config_file,
+ "set an alternative location for the configuration file");
+ ("--no-fork", Arg.Unit (fun () -> daemonize := false),
+ "to request that the daemon does not fork");
+ ("--reraise-top-level", Arg.Unit (fun () -> reraise_top_level := true),
+ "reraise exceptions caught at the top level");
+ ("--no-access-log", Arg.Unit (fun () -> activate_access_log := false),
+ "do not create a xenstore-access.log file");
+ ("--pid-file", Arg.Set_string pidfile, ""); (* for compatibility *)
+ ("-T", Arg.Set_string tracefile, ""); (* for compatibility *)
+ ("--restart", Arg.Set restart, "Read database on starting");
+ ("--disable-socket", Arg.Unit (fun () -> disable_socket := true), "Disable socket");
+ ] in
+ let usage_msg = "usage : xenstored [--config-file <filename>] [--no-domain-init] [--help] [--no-fork] [--reraise-top-level] [--restart] [--disable-socket]" in
+ Arg.parse speclist (fun s -> ()) usage_msg;
+ {
+ domain_init = !domain_init;
+ activate_access_log = !activate_access_log;
+ daemonize = !daemonize;
+ reraise_top_level = !reraise_top_level;
+ config_file = if !config_file <> "" then Some !config_file else None;
+ pidfile = if !pidfile <> "" then Some !pidfile else None;
+ tracefile = if !tracefile <> "" then Some !tracefile else None;
+ restart = !restart;
+ disable_socket = !disable_socket;
+ }
diff --git a/tools/ocaml/xenstored/perms.ml b/tools/ocaml/xenstored/perms.ml
new file mode 100644
index 0000000..99b48f3
--- /dev/null
+++ b/tools/ocaml/xenstored/perms.ml
@@ -0,0 +1,165 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * 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.
+ *)
+
+let activate = ref true
+
+type permty = READ | WRITE | RDWR | NONE
+
+let char_of_permty perm =
+ match perm with
+ | READ -> 'r'
+ | WRITE -> 'w'
+ | RDWR -> 'b'
+ | NONE -> 'n'
+
+let permty_of_char c =
+ match c with
+ | 'r' -> READ
+ | 'w' -> WRITE
+ | 'b' -> RDWR
+ | 'n' -> NONE
+ | _ -> invalid_arg "unknown permission type"
+
+
+(* node permissions *)
+module Node =
+struct
+
+type t =
+{
+ owner: Xc.domid;
+ other: permty;
+ acl: (Xc.domid * permty) list;
+}
+
+let create owner other acl =
+ { owner = owner; other = other; acl = acl }
+
+let get_other perms = perms.other
+let get_acl perms = perms.acl
+let get_owner perm = perm.owner
+
+let default0 = create 0 NONE []
+
+let perm_of_string s =
+ let ty = permty_of_char s.[0]
+ and id = int_of_string (String.sub s 1 (String.length s - 1)) in
+ (id, ty)
+
+let of_strings ls =
+ let vect = List.map (perm_of_string) ls in
+ match vect with
+ | [] -> invalid_arg "permvec empty"
+ | h :: l -> create (fst h) (snd h) l
+
+(* [s] must end with '\000' *)
+let of_string s =
+ let ls = Stringext.String.split '\000' s in
+ let ls = if ls = [] then ls else List.rev (List.tl (List.rev ls)) in
+ of_strings ls
+
+let string_of_perm perm =
+ Printf.sprintf "%c%u" (char_of_permty (snd perm)) (fst perm)
+
+let to_string permvec =
+ let l = ((permvec.owner, permvec.other) :: permvec.acl) in
+ String.concat "\000" (List.map string_of_perm l)
+
+end
+
+
+(* permission of connections *)
+module Connection =
+struct
+
+type elt = Xc.domid * (permty list)
+type t =
+ { main: elt;
+ target: elt option; }
+
+let full_rights : t =
+ { main = 0, [READ; WRITE];
+ target = None }
+
+let create ?(perms=[NONE]) domid : t =
+ { main = (domid, perms);
+ target = None }
+
+let set_target (connection:t) ?(perms=[NONE]) domid =
+ { connection with target = Some (domid, perms) }
+
+let get_owners (connection:t) =
+ match connection.main, connection.target with
+ | c1, Some c2 -> [ fst c1; fst c2 ]
+ | c1, None -> [ fst c1 ]
+
+let is_owner (connection:t) id =
+ match connection.target with
+ | Some target -> fst connection.main = id || fst target = id
+ | None -> fst connection.main = id
+
+let is_dom0 (connection:t) =
+ is_owner connection 0
+
+let restrict (connection:t) domid =
+ match connection.target, connection.main with
+ | None, (0, perms) -> { connection with main = (domid, perms) }
+ | _ -> raise Define.Permission_denied
+
+let elt_to_string (i,p) =
+ Printf.sprintf "%i%S" i (String.concat "" (List.map Stringext.String.of_char (List.map char_of_permty p)))
+
+let to_string connection =
+ Printf.sprintf "%s%s" (elt_to_string connection.main) (Pervasiveext.default "" (Pervasiveext.may elt_to_string connection.target))
+end
+
+(* check if owner of the current connection and of the current node are the same *)
+let check_owner (connection:Connection.t) (node:Node.t) =
+ if !activate && not (Connection.is_dom0 connection)
+ then Connection.is_owner connection (Node.get_owner node)
+ else true
+
+(* check if the current connection has the requested perm on the current node *)
+let check (connection:Connection.t) request (node:Node.t) =
+ let check_acl domainid =
+ let perm =
+ if List.mem_assoc domainid (Node.get_acl node)
+ then List.assoc domainid (Node.get_acl node)
+ else Node.get_other node
+ in
+ match perm, request with
+ | NONE, _ ->
+ Logs.info "io" "Permission denied: Domain %d has no permission" domainid;
+ false
+ | RDWR, _ -> true
+ | READ, READ -> true
+ | WRITE, WRITE -> true
+ | READ, _ ->
+ Logs.info "io" "Permission denied: Domain %d has read only access" domainid;
+ false
+ | WRITE, _ ->
+ Logs.info "io" "Permission denied: Domain %d has write only access" domainid;
+ false
+ in
+ if !activate
+ && not (Connection.is_dom0 connection)
+ && not (check_owner connection node)
+ && not (List.exists check_acl (Connection.get_owners connection))
+ then raise Define.Permission_denied
+
+let equiv perm1 perm2 =
+ (Node.to_string perm1) = (Node.to_string perm2)
diff --git a/tools/ocaml/xenstored/process.ml b/tools/ocaml/xenstored/process.ml
new file mode 100644
index 0000000..bc4a2dd
--- /dev/null
+++ b/tools/ocaml/xenstored/process.ml
@@ -0,0 +1,395 @@
+(*
+ * 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 Transaction_again
+exception Transaction_nested
+exception Domain_not_match
+exception Invalid_Cmd_Args
+
+let allow_debug = ref false
+
+let c_int_of_string s =
+ let v = ref 0 in
+ let is_digit c = c >= '0' && c <= '9' in
+ let len = String.length s in
+ let i = ref 0 in
+ while !i < len && not (is_digit s.[!i]) do incr i done;
+ while !i < len && is_digit s.[!i]
+ do
+ let x = (Char.code s.[!i]) - (Char.code '0') in
+ v := !v * 10 + x;
+ incr i
+ done;
+ !v
+
+(* when we don't want a limit, apply a max limit of 8 arguments.
+ no arguments take more than 3 currently, which is pointless to split
+ more than needed. *)
+let split limit c s =
+ let limit = match limit with None -> 8 | Some x -> x in
+ Stringext.String.split ~limit c s
+
+let split_one_path data con =
+ let args = split (Some 2) '\000' data in
+ match args with
+ | path :: "" :: [] -> Store.Path.create path (Connection.get_path con)
+ | _ -> raise Invalid_Cmd_Args
+
+let process_watch ops cons =
+ let do_op_watch op cons =
+ let recurse = match (fst op) with
+ | Xb.Op.Write -> false
+ | Xb.Op.Mkdir -> false
+ | Xb.Op.Rm -> true
+ | Xb.Op.Setperms -> false
+ | _ -> raise (Failure "huh ?") in
+ Connections.fire_watches cons (snd op) recurse in
+ List.iter (fun op -> do_op_watch op cons) ops
+
+let create_implicit_path t perm path =
+ let dirname = Store.Path.get_parent path in
+ if not (Transaction.path_exists t dirname) then (
+ let rec check_path p =
+ match p with
+ | [] -> []
+ | h :: l ->
+ if Transaction.path_exists t h then
+ check_path l
+ else
+ p in
+ let ret = check_path (List.tl (Store.Path.get_hierarchy dirname)) in
+ List.iter (fun s -> Transaction.mkdir ~with_watch:false t perm s) ret
+ )
+
+(* packets *)
+let do_debug con t domains cons data =
+ if not !allow_debug
+ then None
+ else try match split None '\000' data with
+ | "print" :: msg :: _ ->
+ Logging.xb_op ~tid:0 ~ty:Xb.Op.Debug ~con:"=======>" msg;
+ None
+ | "quota" :: domid :: _ ->
+ let domid = int_of_string domid in
+ let quota = (Store.get_quota t.Transaction.store) in
+ Some (Quota.to_string quota domid ^ "\000")
+ | "mfn" :: domid :: _ ->
+ let domid = int_of_string domid in
+ let con = Connections.find_domain cons domid in
+ Pervasiveext.may (fun dom -> Printf.sprintf "%nd\000" (Domain.get_mfn dom)) (Connection.get_domain con)
+ | _ -> None
+ with _ -> None
+
+let do_directory con t domains cons data =
+ let path = split_one_path data con in
+ let entries = Transaction.ls t (Connection.get_perm con) path in
+ if List.length entries > 0 then
+ (Utils.join_by_null entries) ^ "\000"
+ else
+ ""
+
+let do_read con t domains cons data =
+ let path = split_one_path data con in
+ Transaction.read t (Connection.get_perm con) path
+
+let do_getperms con t domains cons data =
+ let path = split_one_path data con in
+ let perms = Transaction.getperms t (Connection.get_perm con) path in
+ Perms.Node.to_string perms ^ "\000"
+
+let do_watch con t rid domains cons data =
+ let (node, token) =
+ match (split None '\000' data) with
+ | [node; token; ""] -> node, token
+ | _ -> raise Invalid_Cmd_Args
+ in
+ let watch = Connections.add_watch cons con node token in
+ Connection.send_ack con (Transaction.get_id t) rid Xb.Op.Watch;
+ Connection.fire_single_watch watch
+
+let do_unwatch con t domains cons data =
+ let (node, token) =
+ match (split None '\000' data) with
+ | [node; token; ""] -> node, token
+ | _ -> raise Invalid_Cmd_Args
+ in
+ Connections.del_watch cons con node token
+
+let do_transaction_start con t domains cons data =
+ if Transaction.get_id t <> Transaction.none then
+ raise Transaction_nested;
+ let store = Transaction.get_store t in
+ string_of_int (Connection.start_transaction con store) ^ "\000"
+
+let do_transaction_end con t domains cons data =
+ let commit =
+ match (split None '\000' data) with
+ | "T" :: _ -> true
+ | "F" :: _ -> false
+ | x :: _ -> raise (Invalid_argument x)
+ | _ -> raise Invalid_Cmd_Args
+ in
+ let success =
+ Connection.end_transaction con (Transaction.get_id t) commit in
+ if not success then
+ raise Transaction_again;
+ if commit then
+ process_watch (List.rev (Transaction.get_ops t)) cons
+
+let do_introduce con t domains cons data =
+ if not (Connection.is_dom0 con)
+ then raise Define.Permission_denied;
+ let (domid, mfn, port) =
+ match (split None '\000' data) with
+ | domid :: mfn :: port :: _ ->
+ int_of_string domid, Nativeint.of_string mfn, int_of_string port
+ | _ -> raise Invalid_Cmd_Args;
+ in
+ let dom =
+ if Domains.exist domains domid then
+ Domains.find domains domid
+ else try
+ let ndom = Xc.with_intf (fun xc ->
+ Domains.create xc domains domid mfn port) in
+ Connections.add_domain cons ndom;
+ Connections.fire_spec_watches cons "@introduceDomain";
+ ndom
+ with _ -> raise Invalid_Cmd_Args
+ in
+ if (Domain.get_remote_port dom) <> port || (Domain.get_mfn dom) <> mfn then
+ raise Domain_not_match
+
+let do_release con t domains cons data =
+ if not (Connection.is_dom0 con)
+ then raise Define.Permission_denied;
+ let domid =
+ match (split None '\000' data) with
+ | [domid;""] -> int_of_string domid
+ | _ -> raise Invalid_Cmd_Args
+ in
+ let fire_spec_watches = Domains.exist domains domid in
+ Domains.del domains domid;
+ Connections.del_domain cons domid;
+ if fire_spec_watches
+ then Connections.fire_spec_watches cons "@releaseDomain"
+ else raise Invalid_Cmd_Args
+
+let do_resume con t domains cons data =
+ if not (Connection.is_dom0 con)
+ then raise Define.Permission_denied;
+ let domid =
+ match (split None '\000' data) with
+ | domid :: _ -> int_of_string domid
+ | _ -> raise Invalid_Cmd_Args
+ in
+ if Domains.exist domains domid
+ then Domains.resume domains domid
+ else raise Invalid_Cmd_Args
+
+let do_getdomainpath con t domains cons data =
+ let domid =
+ match (split None '\000' data) with
+ | domid :: "" :: [] -> c_int_of_string domid
+ | _ -> raise Invalid_Cmd_Args
+ in
+ sprintf "/local/domain/%u\000" domid
+
+let do_write con t domains cons data =
+ let path, value =
+ match (split (Some 2) '\000' data) with
+ | path :: value :: [] -> Store.Path.create path (Connection.get_path con), value
+ | _ -> raise Invalid_Cmd_Args
+ in
+ create_implicit_path t (Connection.get_perm con) path;
+ Transaction.write t (Connection.get_perm con) path value
+
+let do_mkdir con t domains cons data =
+ let path = split_one_path data con in
+ create_implicit_path t (Connection.get_perm con) path;
+ try
+ Transaction.mkdir t (Connection.get_perm con) path
+ with
+ Define.Already_exist -> ()
+
+let do_rm con t domains cons data =
+ let path = split_one_path data con in
+ try
+ Transaction.rm t (Connection.get_perm con) path
+ with
+ Define.Doesnt_exist -> ()
+
+let do_setperms con t domains cons data =
+ let path, perms =
+ match (split (Some 2) '\000' data) with
+ | path :: perms :: _ ->
+ Store.Path.create path (Connection.get_path con),
+ (Perms.Node.of_string perms)
+ | _ -> raise Invalid_Cmd_Args
+ in
+ Transaction.setperms t (Connection.get_perm con) path perms
+
+let do_error con t domains cons data =
+ raise Define.Unknown_operation
+
+let do_isintroduced con t domains cons data =
+ let domid =
+ match (split None '\000' data) with
+ | domid :: _ -> int_of_string domid
+ | _ -> raise Invalid_Cmd_Args
+ in
+ if domid = Define.domid_self || Domains.exist domains domid then "T\000" else "F\000"
+
+(* [restrict] is in the patch queue since xen3.2 *)
+let do_restrict con t domains cons data =
+ if not (Connection.is_dom0 con)
+ then raise Define.Permission_denied;
+ let domid =
+ match (split None '\000' data) with
+ | [ domid; "" ] -> c_int_of_string domid
+ | _ -> raise Invalid_Cmd_Args
+ in
+ Connection.restrict con domid
+
+(* only in >= xen3.3 *)
+(* we ensure backward compatibility with restrict by counting the number of argument of set_target ... *)
+(* This is not very elegant, but it is safe as 'restrict' only restricts permission of dom0 connections *)
+let do_set_target con t domains cons data =
+ if not (Connection.is_dom0 con)
+ then raise Define.Permission_denied;
+ match split None '\000' data with
+ | [ domid; "" ] -> do_restrict con t domains con data (* backward compatibility with xen3.2-pq *)
+ | [ domid; target_domid; "" ] -> Connections.set_target cons (c_int_of_string domid) (c_int_of_string target_domid)
+ | _ -> raise Invalid_Cmd_Args
+
+(*------------- Generic handling of ty ------------------*)
+let reply_ack fct ty con t rid doms cons data =
+ fct con t doms cons data;
+ Connection.send_ack con (Transaction.get_id t) rid ty;
+ if Transaction.get_id t = Transaction.none then
+ process_watch (Transaction.get_ops t) cons
+
+let reply_data fct ty con t rid doms cons data =
+ let ret = fct con t doms cons data in
+ Connection.send_reply con (Transaction.get_id t) rid ty ret
+
+let reply_data_or_ack fct ty con t rid doms cons data =
+ match fct con t doms cons data with
+ | Some ret -> Connection.send_reply con (Transaction.get_id t) rid ty ret
+ | None -> Connection.send_ack con (Transaction.get_id t) rid ty
+
+let reply_none fct ty con t rid doms cons data =
+ (* let the function reply *)
+ fct con t rid doms cons data
+
+let function_of_type ty =
+ match ty with
+ | Xb.Op.Debug -> reply_data_or_ack do_debug
+ | Xb.Op.Directory -> reply_data do_directory
+ | Xb.Op.Read -> reply_data do_read
+ | Xb.Op.Getperms -> reply_data do_getperms
+ | Xb.Op.Watch -> reply_none do_watch
+ | Xb.Op.Unwatch -> reply_ack do_unwatch
+ | Xb.Op.Transaction_start -> reply_data do_transaction_start
+ | Xb.Op.Transaction_end -> reply_ack do_transaction_end
+ | Xb.Op.Introduce -> reply_ack do_introduce
+ | Xb.Op.Release -> reply_ack do_release
+ | Xb.Op.Getdomainpath -> reply_data do_getdomainpath
+ | Xb.Op.Write -> reply_ack do_write
+ | Xb.Op.Mkdir -> reply_ack do_mkdir
+ | Xb.Op.Rm -> reply_ack do_rm
+ | Xb.Op.Setperms -> reply_ack do_setperms
+ | Xb.Op.Isintroduced -> reply_data do_isintroduced
+ | Xb.Op.Resume -> reply_ack do_resume
+ | Xb.Op.Set_target -> reply_ack do_set_target
+ | Xb.Op.Restrict -> reply_ack do_restrict
+ | _ -> reply_ack do_error
+
+let input_handle_error ~cons ~doms ~fct ~ty ~con ~t ~rid ~data =
+ let reply_error e =
+ Connection.send_error con (Transaction.get_id t) rid e in
+ try
+ fct ty con t rid doms cons data
+ with
+ | Define.Invalid_path -> reply_error "EINVAL"
+ | Define.Already_exist -> reply_error "EEXIST"
+ | Define.Doesnt_exist -> reply_error "ENOENT"
+ | Define.Lookup_Doesnt_exist s -> reply_error "ENOENT"
+ | Define.Permission_denied -> reply_error "EACCES"
+ | Not_found -> reply_error "ENOENT"
+ | Invalid_Cmd_Args -> reply_error "EINVAL"
+ | Invalid_argument i -> reply_error "EINVAL"
+ | Transaction_again -> reply_error "EAGAIN"
+ | Transaction_nested -> reply_error "EBUSY"
+ | Domain_not_match -> reply_error "EINVAL"
+ | Quota.Limit_reached -> reply_error "EQUOTA"
+ | Quota.Data_too_big -> reply_error "E2BIG"
+ | Quota.Transaction_opened -> reply_error "EQUOTA"
+ | (Failure "int_of_string") -> reply_error "EINVAL"
+ | Define.Unknown_operation -> reply_error "ENOSYS"
+
+(**
+ * Nothrow guarantee.
+ *)
+let process_packet ~store ~cons ~doms ~con ~tid ~rid ~ty ~data =
+ try
+ let fct = function_of_type ty in
+ let t =
+ if tid = Transaction.none then
+ Transaction.make tid store
+ else
+ Connection.get_transaction con tid
+ in
+ input_handle_error ~cons ~doms ~fct ~ty ~con ~t ~rid ~data;
+ with exn ->
+ Logs.error "general" "process packet: %s"
+ (Printexc.to_string exn);
+ Connection.send_error con tid rid "EIO"
+
+let write_access_log ~ty ~tid ~con ~data =
+ Logging.xb_op ~ty ~tid ~con:(Connection.get_domstr con) data
+
+let write_answer_log ~ty ~tid ~con ~data =
+ Logging.xb_answer ~ty ~tid ~con:(Connection.get_domstr con) data
+
+let do_input store cons doms con =
+ if Connection.do_input con then (
+ let packet = Connection.pop_in con in
+ let tid, rid, ty, data = Xb.Packet.unpack packet in
+ (* As we don't log IO, do not call an unnecessary sanitize_data
+ Logs.info "io" "[%s] -> [%d] %s \"%s\""
+ (Connection.get_domstr con) tid
+ (Xb.Op.to_string ty) (sanitize_data data); *)
+ process_packet ~store ~cons ~doms ~con ~tid ~rid ~ty ~data;
+ write_access_log ~ty ~tid ~con ~data;
+ Connection.incr_ops con;
+ )
+
+let do_output store cons doms con =
+ if Connection.has_output con then (
+ if Connection.has_new_output con then (
+ let packet = Connection.peek_output con in
+ let tid, rid, ty, data = Xb.Packet.unpack packet in
+ (* As we don't log IO, do not call an unnecessary sanitize_data
+ Logs.info "io" "[%s] <- %s \"%s\""
+ (Connection.get_domstr con)
+ (Xb.Op.to_string ty) (sanitize_data data);*)
+ write_answer_log ~ty ~tid ~con ~data;
+ );
+ ignore (Connection.do_output con)
+ )
+
diff --git a/tools/ocaml/xenstored/quota.ml b/tools/ocaml/xenstored/quota.ml
new file mode 100644
index 0000000..4091e40
--- /dev/null
+++ b/tools/ocaml/xenstored/quota.ml
@@ -0,0 +1,83 @@
+(*
+ * 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 Limit_reached
+exception Data_too_big
+exception Transaction_opened
+
+let warn fmt = Logs.warn "general" fmt
+let activate = ref true
+let maxent = ref (10000)
+let maxsize = ref (4096)
+
+type t = {
+ maxent: int; (* max entities per domU *)
+ maxsize: int; (* max size of data store in one node *)
+ cur: (Xc.domid, int) Hashtbl.t; (* current domains quota *)
+}
+
+let to_string quota domid =
+ if Hashtbl.mem quota.cur domid
+ then Printf.sprintf "dom%i quota: %i/%i" domid (Hashtbl.find quota.cur domid) quota.maxent
+ else Printf.sprintf "dom%i quota: not set" domid
+
+let create () =
+ { maxent = !maxent; maxsize = !maxsize; cur = Hashtbl.create 100; }
+
+let copy quota = { quota with cur = (Hashtbl.copy quota.cur) }
+
+let del quota id = Hashtbl.remove quota.cur id
+
+let _check quota id size =
+ if size > quota.maxsize then (
+ warn "domain %u err create entry: data too big %d" id size;
+ raise Data_too_big
+ );
+ if id > 0 && Hashtbl.mem quota.cur id then
+ let entry = Hashtbl.find quota.cur id in
+ if entry >= quota.maxent then (
+ warn "domain %u cannot create entry: quota reached" id;
+ raise Limit_reached
+ )
+
+let check quota id size =
+ if !activate then
+ _check quota id size
+
+let get_entry quota id = Hashtbl.find quota.cur id
+
+let set_entry quota id nb =
+ if nb = 0
+ then Hashtbl.remove quota.cur id
+ else begin
+ if Hashtbl.mem quota.cur id then
+ Hashtbl.replace quota.cur id nb
+ else
+ Hashtbl.add quota.cur id nb
+ end
+
+let del_entry quota id =
+ try
+ let nb = get_entry quota id in
+ set_entry quota id (nb - 1)
+ with Not_found -> ()
+
+let add_entry quota id =
+ let nb = try get_entry quota id with Not_found -> 0 in
+ set_entry quota id (nb + 1)
+
+let add quota diff =
+ Hashtbl.iter (fun id nb -> set_entry quota id (get_entry quota id + nb)) diff.cur
diff --git a/tools/ocaml/xenstored/store.ml b/tools/ocaml/xenstored/store.ml
new file mode 100644
index 0000000..857f51e
--- /dev/null
+++ b/tools/ocaml/xenstored/store.ml
@@ -0,0 +1,460 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * 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 t = {
+ name: Symbol.t;
+ perms: Perms.Node.t;
+ value: string;
+ children: t list;
+}
+
+let create _name _perms _value =
+ { name = Symbol.of_string _name; perms = _perms; value = _value; children = []; }
+
+let get_owner node = Perms.Node.get_owner node.perms
+let get_children node = node.children
+let get_value node = node.value
+let get_perms node = node.perms
+let get_name node = Symbol.to_string node.name
+
+let set_value node nvalue =
+ if node.value = nvalue
+ then node
+ else { node with value = nvalue }
+
+let set_perms node nperms = { node with perms = nperms }
+
+let add_child node child =
+ { node with children = child :: node.children }
+
+let exists node childname =
+ let childname = Symbol.of_string childname in
+ List.exists (fun n -> n.name = childname) node.children
+
+let find node childname =
+ let childname = Symbol.of_string childname in
+ List.find (fun n -> n.name = childname) node.children
+
+let replace_child node child nchild =
+ (* this is the on-steroid version of the filter one-replace one *)
+ let rec replace_one_in_list l =
+ match l with
+ | [] -> []
+ | h :: tl when h.name = child.name -> nchild :: tl
+ | h :: tl -> h :: replace_one_in_list tl
+ in
+ { node with children = (replace_one_in_list node.children) }
+
+let del_childname node childname =
+ let sym = Symbol.of_string childname in
+ let rec delete_one_in_list l =
+ match l with
+ | [] -> raise Not_found
+ | h :: tl when h.name = sym -> tl
+ | h :: tl -> h :: delete_one_in_list tl
+ in
+ { node with children = (delete_one_in_list node.children) }
+
+let del_all_children node =
+ { node with children = [] }
+
+(* check if the current node can be accessed by the current connection with rperm permissions *)
+let check_perm node connection request =
+ Perms.check connection request node.perms
+
+(* check if the current node is owned by the current connection *)
+let check_owner node connection =
+ if not (Perms.check_owner connection node.perms)
+ then begin
+ Logs.info "io" "Permission denied: Domain %d not owner" (get_owner node);
+ raise Define.Permission_denied;
+ end
+
+let rec recurse fct node = fct node; List.iter (recurse fct) node.children
+
+let unpack node = (Symbol.to_string node.name, node.perms, node.value)
+
+end
+
+module Path = struct
+
+(* represent a path in a store.
+ * [] -> "/"
+ * [ "local"; "domain"; "1" ] -> "/local/domain/1"
+ *)
+type t = string list
+
+let char_is_valid c =
+ (c >= 'a' && c <= 'z') ||
+ (c >= 'A' && c <= 'Z') ||
+ (c >= '0' && c <= '9') ||
+ c = '_' || c = '-' || c = '@'
+
+let name_is_valid name =
+ name <> "" && Stringext.String.fold_left (fun accu c -> accu && char_is_valid c) true name
+
+let is_valid path =
+ List.for_all name_is_valid path
+
+let of_string s =
+ if s.[0] = '@'
+ then [s]
+ else if s = "/"
+ then []
+ else match Stringext.String.split '/' s with
+ | "" :: path when is_valid path -> path
+ | _ -> raise Define.Invalid_path
+
+let create path connection_path =
+ of_string (Utils.path_validate path connection_path)
+
+let to_string t =
+ "/" ^ (String.concat "/" t)
+
+let to_string_list x = x
+
+let get_parent t =
+ if t = [] then [] else List.rev (List.tl (List.rev t))
+
+let get_hierarchy path =
+ Utils.get_hierarchy path
+
+let get_common_prefix p1 p2 =
+ let rec compare l1 l2 =
+ match l1, l2 with
+ | h1 :: tl1, h2 :: tl2 ->
+ if h1 = h2 then h1 :: (compare tl1 tl2) else []
+ | _, [] | [], _ ->
+ (* if l1 or l2 is empty, we found the equal part already *)
+ []
+ in
+ compare p1 p2
+
+let rec lookup_modify node path fct =
+ match path with
+ | [] -> raise (Define.Invalid_path)
+ | h :: [] -> fct node h
+ | h :: l ->
+ let (n, c) =
+ if not (Node.exists node h) then
+ raise (Define.Lookup_Doesnt_exist h)
+ else
+ (node, Node.find node h) in
+ let nc = lookup_modify c l fct in
+ Node.replace_child n c nc
+
+let apply_modify rnode path fct =
+ lookup_modify rnode path fct
+
+let rec lookup_get node path =
+ match path with
+ | [] -> raise (Define.Invalid_path)
+ | h :: [] ->
+ (try
+ Node.find node h
+ with Not_found ->
+ raise Define.Doesnt_exist)
+ | h :: l -> let cnode = Node.find node h in lookup_get cnode l
+
+let get_node rnode path =
+ if path = [] then
+ Some rnode
+ else (
+ try Some (lookup_get rnode path) with Define.Doesnt_exist -> None
+ )
+
+(* get the deepest existing node for this path *)
+let rec get_deepest_existing_node node = function
+ | [] -> node
+ | h :: t ->
+ try get_deepest_existing_node (Node.find node h) t
+ with Not_found -> node
+
+let set_node rnode path nnode =
+ let quota = Quota.create () in
+ if !Quota.activate then Node.recurse (fun node -> Quota.add_entry quota (Node.get_owner node)) nnode;
+ if path = [] then
+ nnode, quota
+ else
+ let set_node node name =
+ try
+ let ent = Node.find node name in
+ if !Quota.activate then Node.recurse (fun node -> Quota.del_entry quota (Node.get_owner node)) ent;
+ Node.replace_child node ent nnode
+ with Not_found ->
+ Node.add_child node nnode
+ in
+ apply_modify rnode path set_node, quota
+
+(* read | ls | getperms use this *)
+let rec lookup node path fct =
+ match path with
+ | [] -> raise (Define.Invalid_path)
+ | h :: [] -> fct node h
+ | h :: l -> let cnode = Node.find node h in lookup cnode l fct
+
+let apply rnode path fct =
+ lookup rnode path fct
+end
+
+type t =
+{
+ mutable stat_transaction_coalesce: int;
+ mutable stat_transaction_abort: int;
+ mutable root: Node.t;
+ mutable quota: Quota.t;
+}
+
+let get_root store = store.root
+let set_root store root = store.root <- root
+
+let get_quota store = store.quota
+let set_quota store quota = store.quota <- quota
+
+(* modifying functions *)
+let path_mkdir store perm path =
+ let do_mkdir node name =
+ try
+ let ent = Node.find node name in
+ Node.check_perm ent perm Perms.WRITE;
+ raise Define.Already_exist
+ with Not_found ->
+ Node.check_perm node perm Perms.WRITE;
+ Node.add_child node (Node.create name node.Node.perms "") in
+ if path = [] then
+ store.root
+ else
+ Path.apply_modify store.root path do_mkdir
+
+let path_write store perm path value =
+ let node_created = ref false in
+ let do_write node name =
+ try
+ let ent = Node.find node name in
+ Node.check_perm ent perm Perms.WRITE;
+ let nent = Node.set_value ent value in
+ Node.replace_child node ent nent
+ with Not_found ->
+ node_created := true;
+ Node.check_perm node perm Perms.WRITE;
+ Node.add_child node (Node.create name node.Node.perms value) in
+ if path = [] then (
+ Node.check_perm store.root perm Perms.WRITE;
+ Node.set_value store.root value, false
+ ) else
+ Path.apply_modify store.root path do_write, !node_created
+
+let path_rm store perm path =
+ let do_rm node name =
+ try
+ let ent = Node.find node name in
+ Node.check_perm ent perm Perms.WRITE;
+ Node.del_childname node name
+ with Not_found ->
+ raise Define.Doesnt_exist in
+ if path = [] then
+ Node.del_all_children store.root
+ else
+ Path.apply_modify store.root path do_rm
+
+let path_setperms store perm path perms =
+ if path = [] then
+ Node.set_perms store.root perms
+ else
+ let do_setperms node name =
+ let c = Node.find node name in
+ Node.check_owner c perm;
+ Node.check_perm c perm Perms.WRITE;
+ let nc = Node.set_perms c perms in
+ Node.replace_child node c nc
+ in
+ Path.apply_modify store.root path do_setperms
+
+(* accessing functions *)
+let get_node store path =
+ Path.get_node store.root path
+
+let get_deepest_existing_node store path =
+ Path.get_deepest_existing_node store.root path
+
+let read store perm path =
+ let do_read node name =
+ let ent = Node.find node name in
+ Node.check_perm ent perm Perms.READ;
+ ent.Node.value
+ in
+ Path.apply store.root path do_read
+
+let ls store perm path =
+ let children =
+ if path = [] then
+ (Node.get_children store.root)
+ else
+ let do_ls node name =
+ let cnode = Node.find node name in
+ Node.check_perm cnode perm Perms.READ;
+ cnode.Node.children in
+ Path.apply store.root path do_ls in
+ List.rev (List.map (fun n -> Symbol.to_string n.Node.name) children)
+
+let getperms store perm path =
+ if path = [] then
+ (Node.get_perms store.root)
+ else
+ let fct n name =
+ let c = Node.find n name in
+ Node.check_perm c perm Perms.READ;
+ c.Node.perms in
+ Path.apply store.root path fct
+
+let path_exists store path =
+ if path = [] then
+ true
+ else
+ try
+ let check_exist node name =
+ ignore(Node.find node name);
+ true in
+ Path.apply store.root path check_exist
+ with Not_found -> false
+
+
+(* others utils *)
+let traversal root_node f =
+ let rec _traversal path node =
+ f path node;
+ List.iter (_traversal (path @ [ Symbol.to_string node.Node.name ])) node.Node.children
+ in
+ _traversal [] root_node
+
+let dump_store_buf root_node =
+ let buf = Buffer.create 8192 in
+ let dump_node path node =
+ let pathstr = String.concat "/" path in
+ Printf.bprintf buf "%s/%s{%s}" pathstr (Symbol.to_string node.Node.name)
+ (String.escaped (Perms.Node.to_string (Node.get_perms node)));
+ if String.length node.Node.value > 0 then
+ Printf.bprintf buf " = %s\n" (String.escaped node.Node.value)
+ else
+ Printf.bprintf buf "\n";
+ in
+ traversal root_node dump_node;
+ buf
+
+let dump_store chan root_node =
+ let buf = dump_store_buf root_node in
+ output_string chan (Buffer.contents buf);
+ Buffer.reset buf
+
+let dump_fct store f = traversal store.root f
+let dump store out_chan = dump_store out_chan store.root
+let dump_stdout store = dump_store stdout store.root
+let dump_buffer store = dump_store_buf store.root
+
+
+(* modifying functions with quota udpate *)
+let set_node store path node =
+ let root, quota_diff = Path.set_node store.root path node in
+ store.root <- root;
+ Quota.add store.quota quota_diff
+
+let write store perm path value =
+ let owner = Node.get_owner (get_deepest_existing_node store path) in
+ Quota.check store.quota owner (String.length value);
+ let root, node_created = path_write store perm path value in
+ store.root <- root;
+ if node_created
+ then Quota.add_entry store.quota owner
+
+let mkdir store perm path =
+ let owner = Node.get_owner (get_deepest_existing_node store path) in
+ Quota.check store.quota owner 0;
+ store.root <- path_mkdir store perm path;
+ Quota.add_entry store.quota owner
+
+let rm store perm path =
+ let rmed_node = Path.get_node store.root path in
+ match rmed_node with
+ | None -> raise Define.Doesnt_exist
+ | Some rmed_node ->
+ store.root <- path_rm store perm path;
+ Node.recurse (fun node -> Quota.del_entry store.quota (Node.get_owner node)) rmed_node
+
+let setperms store perm path nperms =
+ match Path.get_node store.root path with
+ | None -> raise Define.Doesnt_exist
+ | Some node ->
+ let old_owner = Node.get_owner node in
+ let new_owner = Perms.Node.get_owner nperms in
+ Quota.check store.quota new_owner 0;
+ store.root <- path_setperms store perm path nperms;
+ Quota.del_entry store.quota old_owner;
+ Quota.add_entry store.quota new_owner
+
+type ops = {
+ store: t;
+ write: Path.t -> string -> unit;
+ mkdir: Path.t -> unit;
+ rm: Path.t -> unit;
+ setperms: Path.t -> Perms.Node.t -> unit;
+ ls: Path.t -> string list;
+ read: Path.t -> string;
+ getperms: Path.t -> Perms.Node.t;
+ path_exists: Path.t -> bool;
+}
+
+let get_ops store perms = {
+ store = store;
+ write = write store perms;
+ mkdir = mkdir store perms;
+ rm = rm store perms;
+ setperms = setperms store perms;
+ ls = ls store perms;
+ read = read store perms;
+ getperms = getperms store perms;
+ path_exists = path_exists store;
+}
+
+let create () = {
+ stat_transaction_coalesce = 0;
+ stat_transaction_abort = 0;
+ root = Node.create "" Perms.Node.default0 "";
+ quota = Quota.create ();
+}
+let copy store = {
+ stat_transaction_coalesce = store.stat_transaction_coalesce;
+ stat_transaction_abort = store.stat_transaction_abort;
+ root = store.root;
+ quota = Quota.copy store.quota;
+}
+
+let mark_symbols store =
+ Node.recurse (fun node -> Symbol.mark_as_used node.Node.name) store.root
+
+let incr_transaction_coalesce store =
+ store.stat_transaction_coalesce <- store.stat_transaction_coalesce + 1
+let incr_transaction_abort store =
+ store.stat_transaction_abort <- store.stat_transaction_abort + 1
+
+let stats store =
+ let nb_nodes = ref 0 in
+ traversal store.root (fun path node ->
+ incr nb_nodes
+ );
+ !nb_nodes, store.stat_transaction_abort, store.stat_transaction_coalesce
diff --git a/tools/ocaml/xenstored/symbol.ml b/tools/ocaml/xenstored/symbol.ml
new file mode 100644
index 0000000..4420c6a
--- /dev/null
+++ b/tools/ocaml/xenstored/symbol.ml
@@ -0,0 +1,76 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 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.
+ *)
+
+type t = int
+
+type 'a record = { data: 'a; mutable garbage: bool }
+let int_string_tbl : (int,string record) Hashtbl.t = Hashtbl.create 1024
+let string_int_tbl : (string,int) Hashtbl.t = Hashtbl.create 1024
+
+let created_counter = ref 0
+let used_counter = ref 0
+
+let count = ref 0
+let rec fresh () =
+ if Hashtbl.mem int_string_tbl !count
+ then begin
+ incr count;
+ fresh ()
+ end else
+ !count
+
+let new_record v = { data=v; garbage=false }
+
+let of_string name =
+ if Hashtbl.mem string_int_tbl name
+ then begin
+ incr used_counter;
+ Hashtbl.find string_int_tbl name
+ end else begin
+ let i = fresh () in
+ incr created_counter;
+ Hashtbl.add string_int_tbl name i;
+ Hashtbl.add int_string_tbl i (new_record name);
+ i
+ end
+
+let to_string i =
+ (Hashtbl.find int_string_tbl i).data
+
+let mark_all_as_unused () =
+ Hashtbl.iter (fun _ v -> v.garbage <- true) int_string_tbl
+
+let mark_as_used symb =
+ let record1 = Hashtbl.find int_string_tbl symb in
+ record1.garbage <- false
+
+let garbage () =
+ let records = Hashtbl.fold (fun symb record accu ->
+ if record.garbage then (symb, record.data) :: accu else accu
+ ) int_string_tbl [] in
+ let remove (int,string) =
+ Hashtbl.remove int_string_tbl int;
+ Hashtbl.remove string_int_tbl string
+ in
+ created_counter := 0;
+ used_counter := 0;
+ List.iter remove records
+
+let stats () =
+ Hashtbl.length string_int_tbl
+
+let created () = !created_counter
+let used () = !used_counter
diff --git a/tools/ocaml/xenstored/symbol.mli b/tools/ocaml/xenstored/symbol.mli
new file mode 100644
index 0000000..8ed709f
--- /dev/null
+++ b/tools/ocaml/xenstored/symbol.mli
@@ -0,0 +1,52 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 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.
+ *)
+
+(** Node names *)
+
+(** Xenstore nodes names are often the same, ie. "local", "domain", "device", ... so it is worth to
+ manipulate them through the use of small identifiers that we call symbols. These symbols can be
+ compared in constant time (as opposite to strings) and should help the ocaml GC. *)
+
+type t
+(** The type of symbols. *)
+
+val of_string : string -> t
+(** Convert a string into a symbol. *)
+
+val to_string : t -> string
+(** Convert a symbol into a string. *)
+
+(** {6 Garbage Collection} *)
+
+(** Symbols need to be regulary garbage collected. The following steps should be followed:
+- mark all the knowns symbols as unused (with [mark_all_as_unused]);
+- mark all the symbols really usefull as used (with [mark_as_used]); and
+- finally, call [garbage] *)
+
+val mark_all_as_unused : unit -> unit
+val mark_as_used : t -> unit
+val garbage : unit -> unit
+
+(** {6 Statistics } *)
+
+val stats : unit -> int
+(** Get the number of used symbols. *)
+
+val created : unit -> int
+(** Returns the number of symbols created since the last GC. *)
+
+val used : unit -> int
+(** Returns the number of existing symbols used since the last GC *)
diff --git a/tools/ocaml/xenstored/transaction.ml b/tools/ocaml/xenstored/transaction.ml
new file mode 100644
index 0000000..bf1f6aa
--- /dev/null
+++ b/tools/ocaml/xenstored/transaction.ml
@@ -0,0 +1,197 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Thomas Gazagnaire <thomas.gazagnaire@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 none = 0
+let test_eagain = ref false
+let do_coalesce = ref true
+
+let check_parents_perms_identical root1 root2 path =
+ let hierarch = Store.Path.get_hierarchy path in
+ let permdiff = List.fold_left (fun acc path ->
+ let n1 = Store.Path.get_node root1 path
+ and n2 = Store.Path.get_node root2 path in
+ match n1, n2 with
+ | Some n1, Some n2 ->
+ not (Perms.equiv (Store.Node.get_perms n1) (Store.Node.get_perms n2)) || acc
+ | _ ->
+ true || acc
+ ) false hierarch in
+ (not permdiff)
+
+let get_lowest path1 path2 =
+ match path2 with
+ | None -> Some path1
+ | Some path2 -> Some (Store.Path.get_common_prefix path1 path2)
+
+let test_coalesce oldroot currentroot optpath =
+ match optpath with
+ | None -> true
+ | Some path ->
+ let oldnode = Store.Path.get_node oldroot path
+ and currentnode = Store.Path.get_node currentroot path in
+
+ match oldnode, currentnode with
+ | (Some oldnode), (Some currentnode) ->
+ if oldnode == currentnode then (
+ check_parents_perms_identical oldroot currentroot path
+ ) else (
+ false
+ )
+ | None, None -> (
+ (* ok then it doesn't exists in the old version and the current version,
+ just sneak it in as a child of the parent node if it exists, or else fail *)
+ let pnode = Store.Path.get_node currentroot (Store.Path.get_parent path) in
+ match pnode with
+ | None -> false (* ok it doesn't exists, just bail out. *)
+ | Some pnode -> true
+ )
+ | _ ->
+ false
+
+let can_coalesce oldroot currentroot path =
+ if !do_coalesce then
+ try test_coalesce oldroot currentroot path with _ -> false
+ else
+ false
+
+type ty = No | Full of (int * Store.Node.t * Store.t)
+
+type t = {
+ ty: ty;
+ store: Store.t;
+ mutable ops: (Xb.Op.operation * Store.Path.t) list;
+ mutable read_lowpath: Store.Path.t option;
+ mutable write_lowpath: Store.Path.t option;
+}
+
+let make id store =
+ let ty = if id = none then No else Full(id, Store.get_root store, store) in
+ {
+ ty = ty;
+ store = if id = none then store else Store.copy store;
+ ops = [];
+ read_lowpath = None;
+ write_lowpath = None;
+ }
+
+let get_id t = match t.ty with No -> none | Full (id, _, _) -> id
+let get_store t = t.store
+let get_ops t = t.ops
+
+let add_wop t ty path = t.ops <- (ty, path) :: t.ops
+let set_read_lowpath t path = t.read_lowpath <- get_lowest path t.read_lowpath
+let set_write_lowpath t path = t.write_lowpath <- get_lowest path t.write_lowpath
+
+let path_exists t path = Store.path_exists t.store path
+
+let write t perm path value =
+ let path_exists = path_exists t path in
+ Store.write t.store perm path value;
+ if path_exists
+ then set_write_lowpath t path
+ else set_write_lowpath t (Store.Path.get_parent path);
+ add_wop t Xb.Op.Write path
+
+let mkdir ?(with_watch=true) t perm path =
+ Store.mkdir t.store perm path;
+ set_write_lowpath t path;
+ if with_watch then
+ add_wop t Xb.Op.Mkdir path
+
+let setperms t perm path perms =
+ Store.setperms t.store perm path perms;
+ set_write_lowpath t path;
+ add_wop t Xb.Op.Setperms path
+
+let rm t perm path =
+ Store.rm t.store perm path;
+ set_write_lowpath t (Store.Path.get_parent path);
+ add_wop t Xb.Op.Rm path
+
+let ls t perm path =
+ let r = Store.ls t.store perm path in
+ set_read_lowpath t path;
+ r
+
+let read t perm path =
+ let r = Store.read t.store perm path in
+ set_read_lowpath t path;
+ r
+
+let getperms t perm path =
+ let r = Store.getperms t.store perm path in
+ set_read_lowpath t path;
+ r
+
+let commit ~con t =
+ let has_write_ops = List.length t.ops > 0 in
+ let has_coalesced = ref false in
+ let has_commited =
+ match t.ty with
+ | No -> true
+ | Full (id, oldroot, cstore) ->
+ let commit_partial oldroot cstore store =
+ (* get the lowest path of the query and verify that it hasn't
+ been modified by others transactions. *)
+ if can_coalesce oldroot (Store.get_root cstore) t.read_lowpath
+ && can_coalesce oldroot (Store.get_root cstore) t.write_lowpath then (
+ Pervasiveext.maybe (fun p ->
+ let n = Store.get_node store p in
+
+ (* it has to be in the store, otherwise it means bugs
+ in the lowpath registration. we don't need to handle none. *)
+ Pervasiveext.maybe (fun n -> Store.set_node cstore p n) n;
+ Logging.write_coalesce ~tid:(get_id t) ~con (Store.Path.to_string p);
+ ) t.write_lowpath;
+ Pervasiveext.maybe (fun p ->
+ Logging.read_coalesce ~tid:(get_id t) ~con (Store.Path.to_string p)
+ ) t.read_lowpath;
+ has_coalesced := true;
+ Store.incr_transaction_coalesce cstore;
+ true
+ ) else (
+ (* cannot do anything simple, just discard the queries,
+ and the client need to redo it later *)
+ Store.incr_transaction_abort cstore;
+ false
+ )
+ in
+ let try_commit oldroot cstore store =
+ if oldroot == Store.get_root cstore then (
+ (* move the new root to the current store, if the oldroot
+ has not been modified *)
+ if has_write_ops then (
+ Store.set_root cstore (Store.get_root store);
+ Store.set_quota cstore (Store.get_quota store)
+ );
+ true
+ ) else
+ (* we try a partial commit if possible *)
+ commit_partial oldroot cstore store
+ in
+ if !test_eagain && Random.int 3 = 0 then
+ false
+ else
+ try_commit oldroot cstore t.store
+ in
+ if has_commited && has_write_ops then
+ Disk.write t.store;
+ if not has_commited
+ then Logging.conflict ~tid:(get_id t) ~con
+ else if not !has_coalesced
+ then Logging.commit ~tid:(get_id t) ~con;
+ has_commited
diff --git a/tools/ocaml/xenstored/utils.ml b/tools/ocaml/xenstored/utils.ml
new file mode 100644
index 0000000..115d617
--- /dev/null
+++ b/tools/ocaml/xenstored/utils.ml
@@ -0,0 +1,107 @@
+(*
+ * 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
+open Pervasiveext
+
+(* lists utils *)
+let filter_out filter l =
+ List.filter (fun x -> not (List.mem x filter)) l
+
+let filter_in filter l =
+ List.filter (fun x -> List.mem x filter) l
+
+let list_remove element l =
+ List.filter (fun e -> e != element) l
+
+let list_tl_multi n l =
+ let rec do_tl i x =
+ if i = 0 then x else do_tl (i - 1) (List.tl x)
+ in
+ do_tl n l
+
+(* string utils *)
+let get_hierarchy path =
+ let l = List.length path in
+ let revpath = List.rev path in
+ let rec sub i =
+ let x = List.rev (list_tl_multi (l - i) revpath) in
+ if i = l then [ x ] else x :: sub (i + 1)
+ in
+ sub 0
+
+let hexify s =
+ let hexseq_of_char c = sprintf "%02x" (Char.code c) in
+ let hs = String.create (String.length s * 2) in
+ for i = 0 to String.length s - 1
+ do
+ let seq = hexseq_of_char s.[i] in
+ hs.[i * 2] <- seq.[0];
+ hs.[i * 2 + 1] <- seq.[1];
+ done;
+ hs
+
+let unhexify hs =
+ let char_of_hexseq seq0 seq1 = Char.chr (int_of_string (sprintf "0x%c%c" seq0 seq1)) in
+ let s = String.create (String.length hs / 2) in
+ for i = 0 to String.length s - 1
+ do
+ s.[i] <- char_of_hexseq hs.[i * 2] hs.[i * 2 + 1]
+ done;
+ s
+
+let trim_path path =
+ try
+ let rindex = String.rindex path '/' in
+ String.sub path 0 rindex
+ with
+ Not_found -> ""
+
+let join_by_null ls = String.concat "\000" ls
+
+(* unix utils *)
+let create_unix_socket name =
+ Unixext.unlink_safe name;
+ Unixext.mkdir_rec (Filename.dirname name) 0o700;
+ let sockaddr = Unix.ADDR_UNIX(name) in
+ let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+ Unix.bind sock sockaddr;
+ Unix.listen sock 1;
+ sock
+
+let read_file_single_integer filename =
+ let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in
+ let buf = String.make 20 (char_of_int 0) in
+ let sz = Unix.read fd buf 0 20 in
+ Unix.close fd;
+ int_of_string (String.sub buf 0 sz)
+
+let path_complete path connection_path =
+ if String.get path 0 <> '/' then
+ connection_path ^ path
+ else
+ path
+
+let path_validate path connection_path =
+ if String.length path = 0 || String.length path > 1024 then
+ raise Define.Invalid_path
+ else
+ let cpath = path_complete path connection_path in
+ if String.get cpath 0 <> '/' then
+ raise Define.Invalid_path
+ else
+ cpath
+
diff --git a/tools/ocaml/xenstored/xenstored.conf b/tools/ocaml/xenstored/xenstored.conf
new file mode 100644
index 0000000..0e0e5fb
--- /dev/null
+++ b/tools/ocaml/xenstored/xenstored.conf
@@ -0,0 +1,30 @@
+# default xenstored config
+
+# Where the pid file is stored
+pid-file = /var/run/xensource/xenstored.pid
+
+# Randomly failed a transaction with EAGAIN. Used for testing Xs user
+test-eagain = true
+
+# Activate transaction merge support
+merge-activate = true
+
+# Activate node permission system
+perms-activate = true
+
+# Activate quota
+quota-activate = true
+quota-maxentity = 1000
+quota-maxsize = 2048
+quota-maxwatch = 100
+quota-transaction = 10
+
+# Activate filed base backend
+persistant = false
+
+# Logs
+log = error;general;file:/var/log/xenstored.log
+log = warn;general;file:/var/log/xenstored.log
+log = info;general;file:/var/log/xenstored.log
+
+# log = debug;io;file:/var/log/xenstored-io.log
diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xenstored.ml
new file mode 100644
index 0000000..36e01ad
--- /dev/null
+++ b/tools/ocaml/xenstored/xenstored.ml
@@ -0,0 +1,404 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * 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.
+ *)
+
+open Printf
+open Parse_arg
+open Pervasiveext
+open Logging
+
+(*------------ event klass processors --------------*)
+let process_connection_fds store cons domains rset wset =
+ let try_fct fct c =
+ try
+ fct store cons domains c
+ with
+ | Unix.Unix_error(err, "write", _) ->
+ Connections.del_anonymous cons c;
+ error "closing socket connection: write error: %s"
+ (Unix.error_message err)
+ | Unix.Unix_error(err, "read", _) ->
+ Connections.del_anonymous cons c;
+ if err <> Unix.ECONNRESET then
+ error "closing socket connection: read error: %s"
+ (Unix.error_message err)
+ | Xb.End_of_file ->
+ Connections.del_anonymous cons c;
+ debug "closing socket connection"
+ in
+ let process_fdset_with fds fct =
+ List.iter (fun fd ->
+ try try_fct fct (Connections.find cons fd)
+ with Not_found -> ()) fds
+ in
+ process_fdset_with rset Process.do_input;
+ process_fdset_with wset Process.do_output
+
+let process_domains store cons domains =
+ let do_io_domain domain =
+ let con = Connections.find_domain cons (Domain.get_id domain) in
+ Process.do_input store cons domains con;
+ Process.do_output store cons domains con in
+ Domains.iter domains do_io_domain
+
+let sigusr1_handler store =
+ try
+ let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ]
+ 0o600 "/var/run/xenstored/db.debug" in
+ finally (fun () -> Store.dump store channel)
+ (fun () -> close_out channel)
+ with _ ->
+ ()
+
+let sighup_handler _ =
+ try Logs.reopen (); info "Log re-opened" with _ -> ()
+
+let config_filename cf =
+ match cf.config_file with
+ | Some name -> name
+ | None -> Define.default_config_dir ^ "/xenstored.conf"
+
+let default_pidfile = "/var/run/xenstored.pid"
+
+let parse_config filename =
+ let pidfile = ref default_pidfile in
+ let set_log s =
+ let ls = Stringext.String.split ~limit:3 ';' s in
+ let level, key, logger = match ls with
+ | [ level; key; logger ] -> level, key, logger
+ | _ -> failwith "format mismatch: expecting 3 arguments" in
+
+ let loglevel = match level with
+ | "debug" -> Log.Debug
+ | "info" -> Log.Info
+ | "warn" -> Log.Warn
+ | "error" -> Log.Error
+ | s -> failwith (sprintf "Unknown log level: %s" s) in
+
+ (* if key is empty, append to the default logger *)
+ let append =
+ if key = "" then
+ Logs.append_default
+ else
+ Logs.append key in
+ append loglevel logger in
+ let options = [
+ ("merge-activate", Config.Set_bool Transaction.do_coalesce);
+ ("perms-activate", Config.Set_bool Perms.activate);
+ ("quota-activate", Config.Set_bool Quota.activate);
+ ("quota-maxwatch", Config.Set_int Define.maxwatch);
+ ("quota-transaction", Config.Set_int Define.maxtransaction);
+ ("quota-maxentity", Config.Set_int Quota.maxent);
+ ("quota-maxsize", Config.Set_int Quota.maxsize);
+ ("test-eagain", Config.Set_bool Transaction.test_eagain);
+ ("log", Config.String set_log);
+ ("persistant", Config.Set_bool Disk.enable);
+ ("access-log-file", Config.Set_string Logging.access_log_file);
+ ("access-log-nb-files", Config.Set_int Logging.access_log_nb_files);
+ ("access-log-nb-lines", Config.Set_int Logging.access_log_nb_lines);
+ ("access-log-read-ops", Config.Set_bool Logging.log_read_ops);
+ ("access-log-transactions-ops", Config.Set_bool Logging.log_transaction_ops);
+ ("access-log-special-ops", Config.Set_bool Logging.log_special_ops);
+ ("allow-debug", Config.Set_bool Process.allow_debug);
+ ("pid-file", Config.Set_string pidfile); ] in
+ begin try Config.read filename options (fun _ _ -> raise Not_found)
+ with
+ | Config.Error err -> List.iter (fun (k, e) ->
+ match e with
+ | "unknown key" -> eprintf "config: unknown key %s\n" k
+ | _ -> eprintf "config: %s: %s\n" k e
+ ) err;
+ | Sys_error m -> eprintf "error: config: %s\n" m;
+ end;
+ !pidfile
+
+module DB = struct
+
+exception Bad_format of string
+
+let dump_format_header = "$xenstored-dump-format"
+
+let from_channel_f chan domain_f watch_f store_f =
+ let unhexify s = Utils.unhexify s in
+ let getpath s = Store.Path.of_string (Utils.unhexify s) in
+ let header = input_line chan in
+ if header <> dump_format_header then
+ raise (Bad_format "header");
+ let quit = ref false in
+ while not !quit
+ do
+ try
+ let line = input_line chan in
+ let l = Stringext.String.split ',' line in
+ try
+ match l with
+ | "dom" :: domid :: mfn :: port :: []->
+ domain_f (int_of_string domid)
+ (Nativeint.of_string mfn)
+ (int_of_string port)
+ | "watch" :: domid :: path :: token :: [] ->
+ watch_f (int_of_string domid)
+ (unhexify path) (unhexify token)
+ | "store" :: path :: perms :: value :: [] ->
+ store_f (getpath path)
+ (Perms.Node.of_string (unhexify perms ^ "\000"))
+ (unhexify value)
+ | _ ->
+ info "restoring: ignoring unknown line: %s" line
+ with exn ->
+ info "restoring: ignoring unknown line: %s (exception: %s)"
+ line (Printexc.to_string exn);
+ ()
+ with End_of_file ->
+ quit := true
+ done;
+ ()
+
+let from_channel store cons doms chan =
+ (* don't let the permission get on our way, full perm ! *)
+ let op = Store.get_ops store Perms.Connection.full_rights in
+ let xc = Xc.interface_open () in
+
+ let domain_f domid mfn port =
+ let ndom =
+ if domid > 0 then
+ Domains.create xc doms domid mfn port
+ else
+ Domains.create0 false doms
+ in
+ Connections.add_domain cons ndom;
+ in
+ let watch_f domid path token =
+ let con = Connections.find_domain cons domid in
+ ignore (Connections.add_watch cons con path token)
+ in
+ let store_f path perms value =
+ op.Store.write path value;
+ op.Store.setperms path perms
+ in
+ finally (fun () -> from_channel_f chan domain_f watch_f store_f)
+ (fun () -> Xc.interface_close xc)
+
+let from_file store cons doms file =
+ let channel = open_in file in
+ finally (fun () -> from_channel store doms cons channel)
+ (fun () -> close_in channel)
+
+let to_channel store cons chan =
+ let hexify s = Utils.hexify s in
+
+ fprintf chan "%s\n" dump_format_header;
+
+ (* dump connections related to domains; domid, mfn, eventchn port, watches *)
+ Connections.iter_domains cons (fun con -> Connection.dump con chan);
+
+ (* dump the store *)
+ Store.dump_fct store (fun path node ->
+ let name, perms, value = Store.Node.unpack node in
+ let fullpath = (Store.Path.to_string path) ^ "/" ^ name in
+ let permstr = Perms.Node.to_string perms in
+ fprintf chan "store,%s,%s,%s\n" (hexify fullpath) (hexify permstr) (hexify value)
+ );
+ flush chan;
+ ()
+
+
+let to_file store cons file =
+ let channel = open_out_gen [ Open_wronly; Open_creat; Open_trunc; ] 0o600 file in
+ finally (fun () -> to_channel store cons channel)
+ (fun () -> close_out channel)
+end
+
+let _ =
+ printf "Xen Storage Daemon, version %d.%d\n%!"
+ Define.xenstored_major Define.xenstored_minor;
+
+ let cf = do_argv in
+ let pidfile =
+ if Sys.file_exists (config_filename cf) then
+ parse_config (config_filename cf)
+ else
+ default_pidfile
+ in
+
+ (try
+ Unixext.mkdir_rec (Filename.dirname pidfile) 0o755
+ with _ ->
+ ()
+ );
+
+ let rw_sock, ro_sock =
+ if cf.disable_socket then
+ None, None
+ else
+ Some (Unix.handle_unix_error Utils.create_unix_socket Define.xs_daemon_socket),
+ Some (Unix.handle_unix_error Utils.create_unix_socket Define.xs_daemon_socket_ro)
+ in
+
+ if cf.daemonize then
+ Unixext.daemonize ();
+
+ (try Unixext.pidfile_write pidfile with _ -> ());
+
+ info "Xen Storage Daemon, version %d.%d"
+ Define.xenstored_major Define.xenstored_minor;
+
+ (* for compatilibity with old xenstored *)
+ begin match cf.pidfile with
+ | Some pidfile -> Unixext.pidfile_write pidfile
+ | None -> () end;
+
+ let store = Store.create () in
+ let eventchn = Event.init () in
+ let domains = Domains.init eventchn in
+ let cons = Connections.create () in
+
+ let quit = ref false in
+
+ if cf.restart then (
+ DB.from_file store domains cons "/var/run/xenstored/db";
+ Event.bind_virq eventchn
+ ) else (
+ if !Disk.enable then (
+ info "reading store from disk";
+ Disk.read store
+ );
+
+ let localpath = Store.Path.of_string "/local" in
+ if not (Store.path_exists store localpath) then
+ Store.mkdir store (Perms.Connection.create 0) localpath;
+
+ if cf.domain_init then (
+ let usingxiu = Xc.using_injection () in
+ Connections.add_domain cons (Domains.create0 usingxiu domains);
+ Event.bind_virq eventchn
+ );
+ );
+
+ Sys.set_signal Sys.sighup (Sys.Signal_handle sighup_handler);
+ Sys.set_signal Sys.sigterm (Sys.Signal_handle (fun i -> quit := true));
+ Sys.set_signal Sys.sigusr1 (Sys.Signal_handle (fun i -> sigusr1_handler store));
+ Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
+
+ Logging.init cf.activate_access_log (fun () -> DB.to_file store cons "/var/run/xenstored/db");
+
+ let spec_fds =
+ (match rw_sock with None -> [] | Some x -> [ x ]) @
+ (match ro_sock with None -> [] | Some x -> [ x ]) @
+ (if cf.domain_init then [ eventchn.Event.fd ] else [])
+ in
+
+ let xc = Xc.interface_open () in
+
+ let process_special_fds rset =
+ let accept_connection can_write fd =
+ let (cfd, addr) = Unix.accept fd in
+ debug "new connection through socket";
+ Connections.add_anonymous cons cfd can_write
+ and handle_eventchn fd =
+ let port = Event.read_port eventchn in
+ finally (fun () ->
+ if port = eventchn.Event.virq_port then (
+ let (notify, deaddom) = Domains.cleanup xc domains in
+ List.iter (Connections.del_domain cons) deaddom;
+ if deaddom <> [] || notify then
+ Connections.fire_spec_watches cons "@releaseDomain"
+ )
+ ) (fun () -> Event.write_port eventchn port);
+ and do_if_set fd set fct =
+ if List.mem fd set then
+ fct fd in
+
+ maybe (fun fd -> do_if_set fd rset (accept_connection true)) rw_sock;
+ maybe (fun fd -> do_if_set fd rset (accept_connection false)) ro_sock;
+ do_if_set eventchn.Event.fd rset (handle_eventchn)
+ in
+
+ let last_stat_time = ref 0. in
+ let periodic_ops_counter = ref 0 in
+ let periodic_ops () =
+ (* we garbage collect the string->int dictionary after a sizeable amount of operations,
+ * there's no need to be really fast even if we got loose
+ * objects since names are often reuse.
+ *)
+ if Symbol.created () > 1000 || Symbol.used () > 20000
+ then begin
+ Symbol.mark_all_as_unused ();
+ Store.mark_symbols store;
+ Connections.iter cons Connection.mark_symbols;
+ Symbol.garbage ()
+ end;
+
+ (* make sure we don't print general stats faster than 2 min *)
+ let ntime = Unix.gettimeofday () in
+ if ntime > (!last_stat_time +. 120.) then (
+ last_stat_time := ntime;
+
+ let gc = Gc.stat () in
+ let (lanon, lanon_ops, lanon_watchs,
+ ldom, ldom_ops, ldom_watchs) = Connections.stats cons in
+ let store_nodes, store_abort, store_coalesce = Store.stats store in
+ let symtbl_len = Symbol.stats () in
+
+ info "store stat: nodes(%d) t-abort(%d) t-coalesce(%d)"
+ store_nodes store_abort store_coalesce;
+ info "sytbl stat: %d" symtbl_len;
+ info " con stat: anonymous(%d, %d o, %d w) domains(%d, %d o, %d w)"
+ lanon lanon_ops lanon_watchs ldom ldom_ops ldom_watchs;
+ info " mem stat: minor(%.0f) promoted(%.0f) major(%.0f) heap(%d w, %d c) live(%d w, %d b) free(%d w, %d b)"
+ gc.Gc.minor_words gc.Gc.promoted_words gc.Gc.major_words
+ gc.Gc.heap_words gc.Gc.heap_chunks
+ gc.Gc.live_words gc.Gc.live_blocks
+ gc.Gc.free_words gc.Gc.free_blocks
+ )
+ in
+
+ let main_loop () =
+ incr periodic_ops_counter;
+ if !periodic_ops_counter > 20 then (
+ periodic_ops_counter := 0;
+ periodic_ops ();
+ );
+
+ let mw = Connections.has_more_work cons in
+ let inset, outset = Connections.select cons in
+ let timeout = if List.length mw > 0 then 0. else -1. in
+ let rset, wset, _ =
+ try
+ Unix.select (spec_fds @ inset) outset [] timeout
+ with Unix.Unix_error(Unix.EINTR, _, _) ->
+ [], [], [] in
+ let sfds, cfds =
+ List.partition (fun fd -> List.mem fd spec_fds) rset in
+ if List.length sfds > 0 then
+ process_special_fds sfds;
+ if List.length cfds > 0 || List.length wset > 0 then
+ process_connection_fds store cons domains cfds wset;
+ process_domains store cons domains
+ in
+
+ while not !quit
+ do
+ try
+ main_loop ()
+ with exc ->
+ error "caught exception %s" (Printexc.to_string exc);
+ if cf.reraise_top_level then
+ raise exc
+ done;
+ info "stopping xenstored";
+ DB.to_file store cons "/var/run/xenstored/db";
+ ()
[-- 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
* [PATCH 3/6] add compilation makefile to ocaml directory
2010-03-01 11:59 [RFC][PATCH 0/6] merge ocaml xenstored and dependencies Vincent Hanquez
2010-03-01 11:59 ` [PATCH 1/6] add ocaml libs (xc/xb/xs/eventchn) Vincent Hanquez
2010-03-01 11:59 ` [PATCH 2/6] add ocaml xenstored Vincent Hanquez
@ 2010-03-01 11:59 ` Vincent Hanquez
2010-03-01 11:59 ` [PATCH 4/6] remove hook from external ocaml repository Vincent Hanquez
` (2 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: 446 bytes --]
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
tools/ocaml/Makefile | 36 +++++++++++++++++
tools/ocaml/Makefile.rules | 93 ++++++++++++++++++++++++++++++++++++++++++++
tools/ocaml/common.make | 28 +++++++++++++
3 files changed, 157 insertions(+), 0 deletions(-)
create mode 100644 tools/ocaml/Makefile
create mode 100644 tools/ocaml/Makefile.rules
create mode 100644 tools/ocaml/common.make
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0003-add-compilation-makefile-to-ocaml-directory.patch --]
[-- Type: text/x-patch; name="0003-add-compilation-makefile-to-ocaml-directory.patch", Size: 5488 bytes --]
diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile
new file mode 100644
index 0000000..adc35b4
--- /dev/null
+++ b/tools/ocaml/Makefile
@@ -0,0 +1,36 @@
+XEN_ROOT = ../..
+include $(XEN_ROOT)/tools/Rules.mk
+
+SUBDIRS_LIBS = \
+ libs/uuid libs/stdext libs/mmap \
+ libs/log libs/xc libs/eventchn \
+ libs/xb libs/xs
+
+SUBDIRS_PROGRAMS = xenstored
+
+SUBDIRS = $(SUBDIRS_LIBS) $(SUBDIRS_PROGRAMS)
+
+.PHONY: all
+all: build
+
+.PHONY: build $(SUBDIRS)
+build: $(SUBDIRS)
+
+$(SUBDIRS):
+ @echo " === building $@"
+ @$(MAKE) --no-print-directory -C $@
+
+.PHONY: install install-libs install-program
+install: install-libs install-program
+
+install-program: $(SUBDIRS_PROGRAMS)
+ $(INSTALL_DIR) $(DESTDIR)$(SBINDIR)
+ $(INSTALL_PROG) xenstored/oxenstored $(DESTDIR)$(SBINDIR)
+
+install-libs: $(SUBDIRS_LIBS)
+
+.PHONY: clean
+clean:
+ @for dir in $(SUBDIRS); do \
+ $(MAKE) --no-print-directory -C $$dir clean; \
+ done
diff --git a/tools/ocaml/Makefile.rules b/tools/ocaml/Makefile.rules
new file mode 100644
index 0000000..ee06b73
--- /dev/null
+++ b/tools/ocaml/Makefile.rules
@@ -0,0 +1,93 @@
+ifdef V
+ ifeq ("$(origin V)", "command line")
+ BUILD_VERBOSE = $(V)
+ endif
+endif
+ifndef BUILD_VERBOSE
+ BUILD_VERBOSE = 0
+endif
+ifeq ($(BUILD_VERBOSE),1)
+ E = @true
+ Q =
+else
+ E = @echo
+ Q = @
+endif
+
+ALL_OCAML_OBJS ?= $(OBJS)
+
+%.cmo: %.ml
+ $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -c -o $@ $<,MLC,$@)
+
+%.cmi: %.mli
+ $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -c -o $@ $<,MLI,$@)
+
+%.cmx: %.ml
+ $(call quiet-command, $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<,MLOPT,$@)
+
+%.ml: %.mll
+ $(call quiet-command, $(OCAMLLEX) -q -o $@ $<,MLLEX,$@)
+
+%.ml: %.mly
+ $(call quiet-command, $(OCAMLYACC) -q $<,MLYACC,$@)
+
+%.o: %.c
+ $(call quiet-command, $(CC) $(CFLAGS) -c -o $@ $<,CC,$@)
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< $o
+
+ALL_OCAML_OBJ_SOURCES=$(addsuffix .ml, $(ALL_OCAML_OBJS))
+
+.ocamldep.make: $(ALL_OCAML_OBJ_SOURCES) Makefile $(TOPLEVEL)/Makefile.rules
+ $(call quiet-command, $(OCAMLDEP) $(ALL_OCAML_OBJ_SOURCES) *.mli $o,MLDEP,)
+
+clean: $(CLEAN_HOOKS)
+ $(Q)rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS) $(GENERATED_FILES) .ocamldep.make
+
+quiet-command = $(if $(V),$1,@printf " %-8s %s\n" "$2" "$3" && $1)
+
+mk-caml-lib-native = $(call quiet-command, $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $1 $2 $3,MLA,$1)
+mk-caml-lib-bytecode = $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -a -o $1 $2 $3,MLA,$1)
+
+mk-caml-stubs = $(call quiet-command, $(OCAMLMKLIB) -o `basename $1 .a` $2,MKLIB,$1)
+mk-caml-lib-stubs = \
+ $(call quiet-command, $(AR) rcs $1 $2 && $(OCAMLMKLIB) -o `basename $1 .a | sed -e 's/^lib//'` $2,MKLIB,$1)
+
+# define a library target <name>.cmxa and <name>.cma
+define OCAML_LIBRARY_template
+ $(1).cmxa: lib$(1)_stubs.a $(foreach obj,$($(1)_OBJS),$(obj).cmx)
+ $(call mk-caml-lib-native,$$@, -cclib -l$(1)_stubs, $(foreach obj,$($(1)_OBJS),$(obj).cmx))
+ $(1).cma: $(foreach obj,$($(1)_OBJS),$(obj).cmo)
+ $(call mk-caml-lib-bytecode,$$@, -dllib dll$(1)_stubs.so -cclib -l$(1)_stubs, $$+)
+ $(1)_stubs.a: $(foreach obj,$$($(1)_C_OBJS),$(obj).o)
+ $(call mk-caml-stubs,$$@, $$+)
+ lib$(1)_stubs.a: $(foreach obj,$($(1)_C_OBJS),$(obj).o)
+ $(call mk-caml-lib-stubs,$$@, $$+)
+endef
+
+define OCAML_NOC_LIBRARY_template
+ $(1).cmxa: $(foreach obj,$($(1)_OBJS),$(obj).cmx)
+ $(call mk-caml-lib-native,$$@, , $(foreach obj,$($(1)_OBJS),$(obj).cmx))
+ $(1).cma: $(foreach obj,$($(1)_OBJS),$(obj).cmo)
+ $(call mk-caml-lib-bytecode,$$@, , $$+)
+endef
+
+define OCAML_PROGRAM_template
+ $(1): $(foreach obj,$($(1)_OBJS),$(obj).cmx) $($(1)_EXTRA_DEPS)
+ $(call quiet-command, $(OCAMLOPT) $(OCAMLOPTFLAGS) -o $$@ $($(1)_LIBS) $$+,MLBIN,$$@)
+ $(1).byte: $(foreach obj,$($(1)_OBJS),$(obj).cmo)
+ $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -o $$@ $($(1)_BYTE_LIBS) $$+,MLBIN,$$@)
+endef
+
+define C_PROGRAM_template
+ $(1): $(foreach obj,$($(1)_OBJS),$(obj).o)
+ $(call quiet-command, $(CC) $(CFLAGS) -o $$@ $$+,BIN,$$@)
+endef
+
+-include .ocamldep.make
+
+$(foreach lib,$(OCAML_LIBRARY),$(eval $(call OCAML_LIBRARY_template,$(lib))))
+$(foreach lib,$(OCAML_NOC_LIBRARY),$(eval $(call OCAML_NOC_LIBRARY_template,$(lib))))
+$(foreach p,$(OCAML_PROGRAM),$(eval $(call OCAML_PROGRAM_template,$(p))))
+$(foreach p,$(C_PROGRAM),$(eval $(call C_PROGRAM_template,$(p))))
diff --git a/tools/ocaml/common.make b/tools/ocaml/common.make
new file mode 100644
index 0000000..3b14dfb
--- /dev/null
+++ b/tools/ocaml/common.make
@@ -0,0 +1,28 @@
+CC ?= gcc
+OCAMLOPT ?= ocamlopt
+OCAMLC ?= ocamlc
+OCAMLMKLIB ?= ocamlmklib
+OCAMLDEP ?= ocamldep
+OCAMLLEX ?= ocamllex
+OCAMLYACC ?= ocamlyacc
+
+CFLAGS ?= -Wall -fPIC -O2
+
+XEN_ROOT ?= $(TOPLEVEL)/../xen-unstable.hg
+XEN_DIST_ROOT ?= $(XEN_ROOT)/dist/install
+CFLAGS += -I$(XEN_DIST_ROOT)/usr/include
+
+OCAMLOPTFLAG_G := $(shell $(OCAMLOPT) -h 2>&1 | sed -n 's/^ *\(-g\) .*/\1/p')
+OCAMLOPTFLAGS = $(OCAMLOPTFLAG_G) -ccopt "$(LDFLAGS)" -dtypes $(OCAMLINCLUDE) -cc $(CC) -w F -warn-error F
+OCAMLCFLAGS += -g $(OCAMLINCLUDE) -w F -warn-error F
+
+#LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := echo 0.0
+
+OCAMLABI = $(shell $(OCAMLC) -version)
+OCAMLLIBDIR = $(shell $(OCAMLC) -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+o= >$@.new && mv -f $@.new $@
[-- 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
* [PATCH 4/6] remove hook from external ocaml repository
2010-03-01 11:59 [RFC][PATCH 0/6] merge ocaml xenstored and dependencies Vincent Hanquez
` (2 preceding siblings ...)
2010-03-01 11:59 ` [PATCH 3/6] add compilation makefile to ocaml directory Vincent Hanquez
@ 2010-03-01 11:59 ` Vincent Hanquez
2010-03-01 11:59 ` [PATCH 5/6] add ocaml tools to build if defined. default to n Vincent Hanquez
2010-03-01 11:59 ` [PATCH 6/6] default ocaml tools config variable to y Vincent Hanquez
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: 259 bytes --]
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
Config.mk | 6 ------
tools/Makefile | 21 ---------------------
tools/xenstore/Makefile | 5 -----
3 files changed, 0 insertions(+), 32 deletions(-)
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0004-remove-hook-from-external-ocaml-repository.patch --]
[-- Type: text/x-patch; name="0004-remove-hook-from-external-ocaml-repository.patch", Size: 2257 bytes --]
diff --git a/Config.mk b/Config.mk
index ad86e1e..45a4580 100644
--- a/Config.mk
+++ b/Config.mk
@@ -154,12 +154,6 @@ QEMU_TAG ?= e5d14857cd67490bf956d97c8888c0be95ed3f78
# Thu Feb 18 15:36:29 2010 +0000
# When xen_platform_pci=0 also disable fixed Xen platform ioports
-OCAML_XENSTORED_REPO=http://xenbits.xensource.com/ext/xen-ocaml-tools.hg
-
-# Build OCAML version of xenstored instead of the in-tree C version?
-# This will cause $(OCAML_XENSTORED_REPO) to be cloned.
-CONFIG_OCAML_XENSTORED ?= n
-
# Optional components
XENSTAT_XENTOP ?= y
VTPM_TOOLS ?= n
diff --git a/tools/Makefile b/tools/Makefile
index 48c9802..c34dc86 100644
--- a/tools/Makefile
+++ b/tools/Makefile
@@ -6,7 +6,6 @@ SUBDIRS-y += check
SUBDIRS-y += include
SUBDIRS-y += libxc
SUBDIRS-y += flask
-SUBDIRS-$(CONFIG_OCAML_XENSTORED) += ocaml-xenstored
SUBDIRS-y += xenstore
SUBDIRS-y += misc
SUBDIRS-y += examples
@@ -114,23 +113,3 @@ subdir-clean-ioemu-dir:
$(buildmakevars2shellvars); \
$(MAKE) -C ioemu-dir clean; \
fi
-
-ocaml-xenstored:
- set -ex; \
- rm -rf ocaml-xenstored.tmp; \
- hg clone $(OCAML_XENSTORED_REPO) ocaml-xenstored.tmp; \
- if [ "$(OCAML_XENSTORED_TAG)" ]; then \
- hg -R ocaml-xenstored.tmp update -r $(OCAML_XENSTORED_TAG) ;\
- hg -R ocaml-xenstored.tmp branch mybranch ;\
- fi; \
- mv ocaml-xenstored.tmp ocaml-xenstored; \
-
-subdir-all-ocaml-xenstored subdir-install-ocaml-xenstored: ocaml-xenstored
- $(absolutify_xen_root); \
- $(MAKE) -C ocaml-xenstored $(patsubst subdir-%-ocaml-xenstored,%,$@);
-
-subdir-clean-ocaml-xenstored:
- set -e; if test -d ocaml-xenstored; then \
- $(MAKE) -C ocaml-xenstored clean; \
- fi
-
diff --git a/tools/xenstore/Makefile b/tools/xenstore/Makefile
index f64ba9f..6ef6ff0 100644
--- a/tools/xenstore/Makefile
+++ b/tools/xenstore/Makefile
@@ -95,11 +95,6 @@ tarball: clean
.PHONY: install
install: all
-ifneq ($(CONFIG_OCAML_XENSTORED),y)
- $(INSTALL_DIR) $(DESTDIR)/var/run/xenstored
- $(INSTALL_DIR) $(DESTDIR)/var/lib/xenstored
- $(INSTALL_PROG) xenstored $(DESTDIR)$(SBINDIR)
-endif
$(INSTALL_DIR) $(DESTDIR)$(BINDIR)
$(INSTALL_DIR) $(DESTDIR)$(SBINDIR)
$(INSTALL_DIR) $(DESTDIR)$(INCLUDEDIR)
[-- 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
* [PATCH 5/6] add ocaml tools to build if defined. default to n
2010-03-01 11:59 [RFC][PATCH 0/6] merge ocaml xenstored and dependencies Vincent Hanquez
` (3 preceding siblings ...)
2010-03-01 11:59 ` [PATCH 4/6] remove hook from external ocaml repository Vincent Hanquez
@ 2010-03-01 11:59 ` Vincent Hanquez
2010-03-01 11:59 ` [PATCH 6/6] default ocaml tools config variable to y Vincent Hanquez
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: 177 bytes --]
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
Config.mk | 1 +
tools/Makefile | 2 ++
2 files changed, 3 insertions(+), 0 deletions(-)
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0005-add-ocaml-tools-to-build-if-defined.-default-to-n.patch --]
[-- Type: text/x-patch; name="0005-add-ocaml-tools-to-build-if-defined.-default-to-n.patch", Size: 694 bytes --]
diff --git a/Config.mk b/Config.mk
index 45a4580..a0d2be8 100644
--- a/Config.mk
+++ b/Config.mk
@@ -159,6 +159,7 @@ XENSTAT_XENTOP ?= y
VTPM_TOOLS ?= n
LIBXENAPI_BINDINGS ?= n
PYTHON_TOOLS ?= y
+OCAML_TOOLS ?= n
CONFIG_MINITERM ?= n
CONFIG_LOMOUNT ?= n
diff --git a/tools/Makefile b/tools/Makefile
index c34dc86..58058f9 100644
--- a/tools/Makefile
+++ b/tools/Makefile
@@ -40,6 +40,8 @@ SUBDIRS-$(CONFIG_X86) += xenpaging
ifeq ($(XEN_COMPILE_ARCH),$(XEN_TARGET_ARCH))
SUBDIRS-$(PYTHON_TOOLS) += python
SUBDIRS-$(PYTHON_TOOLS) += pygrub
+
+SUBDIRS-$(OCAML_TOOLS) += ocaml
endif
# For the sake of linking, set the sys-root
[-- 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
* [PATCH 6/6] default ocaml tools config variable to y
2010-03-01 11:59 [RFC][PATCH 0/6] merge ocaml xenstored and dependencies Vincent Hanquez
` (4 preceding siblings ...)
2010-03-01 11:59 ` [PATCH 5/6] add ocaml tools to build if defined. default to n Vincent Hanquez
@ 2010-03-01 11:59 ` Vincent Hanquez
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: 305 bytes --]
fallback mechanism if ocamlopt is not available or if we don't compile
on a linux system (probably need portability fixes for solaris/netbsd/etc).
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
Config.mk | 10 +++++++++-
1 files changed, 9 insertions(+), 1 deletions(-)
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0006-default-ocaml-tools-config-variable-to-y.patch --]
[-- Type: text/x-patch; name="0006-default-ocaml-tools-config-variable-to-y.patch", Size: 540 bytes --]
diff --git a/Config.mk b/Config.mk
index a0d2be8..f36bca8 100644
--- a/Config.mk
+++ b/Config.mk
@@ -159,8 +159,16 @@ XENSTAT_XENTOP ?= y
VTPM_TOOLS ?= n
LIBXENAPI_BINDINGS ?= n
PYTHON_TOOLS ?= y
-OCAML_TOOLS ?= n
+OCAML_TOOLS ?= y
CONFIG_MINITERM ?= n
CONFIG_LOMOUNT ?= n
+ifeq ($(OCAML_TOOLS),y)
+ifeq ($(CONFIG_Linux),y)
+OCAML_TOOLS := $(shell ocamlopt -v > /dev/null 2>&1 && echo "y" || echo "n")
+else
+OCAML_TOOLS := n
+endif
+endif
+
-include $(XEN_ROOT)/.config
[-- 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
end of thread, other threads:[~2010-03-01 11:59 UTC | newest]
Thread overview: 7+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2010-03-01 11:59 [RFC][PATCH 0/6] merge ocaml xenstored and dependencies Vincent Hanquez
2010-03-01 11:59 ` [PATCH 1/6] add ocaml libs (xc/xb/xs/eventchn) Vincent Hanquez
2010-03-01 11:59 ` [PATCH 2/6] add ocaml xenstored Vincent Hanquez
2010-03-01 11:59 ` [PATCH 3/6] add compilation makefile to ocaml directory Vincent Hanquez
2010-03-01 11:59 ` [PATCH 4/6] remove hook from external ocaml repository Vincent Hanquez
2010-03-01 11:59 ` [PATCH 5/6] add ocaml tools to build if defined. default to n Vincent Hanquez
2010-03-01 11:59 ` [PATCH 6/6] default ocaml tools config variable to y Vincent Hanquez
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for NNTP newsgroup(s).