[PATCH v4 05/27] libxc: ocaml: add simple binding for xentoollog (output only).

[Rob Hoes <rob.hoes@citrix.com>]

These bindings allow ocaml code to receive log message via xentoollog
but do not support injecting messages into xentoollog from ocaml.
Receiving log messages from libx{c,l} and forwarding them to ocaml is
the use case which is needed by the following patches.

Add a simple noddy test case (tools/ocaml/test).

Signed-off-by: Ian Campbell <ian.campbell@citrix.com>
Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
Acked-by: David Scott <dave.scott@eu.citrix.com>
---
 .gitignore                                     |    1 +
 .hgignore                                      |    1 +
 tools/ocaml/Makefile                           |    2 +-
 tools/ocaml/Makefile.rules                     |    2 +-
 tools/ocaml/libs/Makefile                      |    1 +
 tools/ocaml/libs/xentoollog/META.in            |    4 +
 tools/ocaml/libs/xentoollog/Makefile           |   61 ++++++++
 tools/ocaml/libs/xentoollog/caml_xentoollog.h  |   24 +++
 tools/ocaml/libs/xentoollog/genlevels.py       |  127 +++++++++++++++
 tools/ocaml/libs/xentoollog/xentoollog.ml.in   |   48 ++++++
 tools/ocaml/libs/xentoollog/xentoollog.mli.in  |   43 ++++++
 tools/ocaml/libs/xentoollog/xentoollog_stubs.c |  196 ++++++++++++++++++++++++
 tools/ocaml/test/Makefile                      |   28 ++++
 tools/ocaml/test/xtl.ml                        |   40 +++++
 14 files changed, 576 insertions(+), 2 deletions(-)
 create mode 100644 tools/ocaml/libs/xentoollog/META.in
 create mode 100644 tools/ocaml/libs/xentoollog/Makefile
 create mode 100644 tools/ocaml/libs/xentoollog/caml_xentoollog.h
 create mode 100755 tools/ocaml/libs/xentoollog/genlevels.py
 create mode 100644 tools/ocaml/libs/xentoollog/xentoollog.ml.in
 create mode 100644 tools/ocaml/libs/xentoollog/xentoollog.mli.in
 create mode 100644 tools/ocaml/libs/xentoollog/xentoollog_stubs.c
 create mode 100644 tools/ocaml/test/Makefile
 create mode 100644 tools/ocaml/test/xtl.ml

diff --git a/.gitignore b/.gitignore
index 3253675..f51c345 100644
--- a/.gitignore
+++ b/.gitignore
@@ -384,6 +384,7 @@ tools/ocaml/libs/xl/_libxl_types.mli.in
 tools/ocaml/libs/xl/xenlight.ml
 tools/ocaml/libs/xl/xenlight.mli
 tools/ocaml/xenstored/oxenstored
+tools/ocaml/test/xtl
 
 tools/debugger/kdd/kdd
 tools/firmware/etherboot/ipxe.tar.gz
diff --git a/.hgignore b/.hgignore
index 05cb0de..bb1b67d 100644
--- a/.hgignore
+++ b/.hgignore
@@ -308,6 +308,7 @@
 ^tools/ocaml/libs/xl/xenlight\.ml$
 ^tools/ocaml/libs/xl/xenlight\.mli$
 ^tools/ocaml/xenstored/oxenstored$
+^tools/ocaml/test/xtl$
 ^tools/autom4te\.cache$
 ^tools/config\.h$
 ^tools/config\.log$
diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile
index 6b22bbe..8e4ca36 100644
--- a/tools/ocaml/Makefile
+++ b/tools/ocaml/Makefile
@@ -1,7 +1,7 @@
 XEN_ROOT = $(CURDIR)/../..
 include $(XEN_ROOT)/tools/Rules.mk
 
-SUBDIRS_PROGRAMS = xenstored
+SUBDIRS_PROGRAMS = xenstored test
 
 SUBDIRS = libs $(SUBDIRS_PROGRAMS)
 
diff --git a/tools/ocaml/Makefile.rules b/tools/ocaml/Makefile.rules
index 5e6d81e..0745e83 100644
--- a/tools/ocaml/Makefile.rules
+++ b/tools/ocaml/Makefile.rules
@@ -24,7 +24,7 @@ ALL_OCAML_OBJS ?= $(OBJS)
 %.cmi: %.mli
 	$(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -c -o $@ $<,MLI,$@)
 
-%.cmx: %.ml
+%.cmx %.o: %.ml
 	$(call quiet-command, $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<,MLOPT,$@)
 
 %.ml: %.mll
diff --git a/tools/ocaml/libs/Makefile b/tools/ocaml/libs/Makefile
index bca0fa2..3afdc89 100644
--- a/tools/ocaml/libs/Makefile
+++ b/tools/ocaml/libs/Makefile
@@ -3,6 +3,7 @@ include $(XEN_ROOT)/tools/Rules.mk
 
 SUBDIRS= \
 	mmap \
+	xentoollog \
 	xc eventchn \
 	xb xs xl
 
diff --git a/tools/ocaml/libs/xentoollog/META.in b/tools/ocaml/libs/xentoollog/META.in
new file mode 100644
index 0000000..7b06683
--- /dev/null
+++ b/tools/ocaml/libs/xentoollog/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Xen Tools Logger Interface"
+archive(byte) = "xentoollog.cma"
+archive(native) = "xentoollog.cmxa"
diff --git a/tools/ocaml/libs/xentoollog/Makefile b/tools/ocaml/libs/xentoollog/Makefile
new file mode 100644
index 0000000..e535ba5
--- /dev/null
+++ b/tools/ocaml/libs/xentoollog/Makefile
@@ -0,0 +1,61 @@
+TOPLEVEL=$(CURDIR)/../..
+XEN_ROOT=$(TOPLEVEL)/../..
+include $(TOPLEVEL)/common.make
+
+CFLAGS += $(CFLAGS_libxenctrl) $(CFLAGS_libxenguest)
+OCAMLINCLUDE +=
+
+OBJS = xentoollog
+INTF = xentoollog.cmi
+LIBS = xentoollog.cma xentoollog.cmxa
+
+LIBS_xentoollog = $(LDLIBS_libxenctrl)
+
+xentoollog_OBJS = $(OBJS)
+xentoollog_C_OBJS = xentoollog_stubs
+
+OCAML_LIBRARY = xentoollog
+
+GENERATED_FILES += xentoollog.ml xentoollog.ml.tmp xentoollog.mli xentoollog.mli.tmp
+GENERATED_FILES += _xtl_levels.mli.in _xtl_levels.ml.in _xtl_levels.inc META
+
+all: $(INTF) $(LIBS)
+
+xentoollog.ml: xentoollog.ml.in _xtl_levels.ml.in
+	$(Q)sed -e '1i\
+(*\
+ * AUTO-GENERATED FILE DO NOT EDIT\
+ * Generated from xentoollog.ml.in and _xtl_levels.ml.in\
+ *)\
+' \
+	    -e '/^(\* @@XTL_LEVELS@@ \*)$$/r_xtl_levels.ml.in' \
+	  < xentoollog.ml.in > xentoollog.ml.tmp
+	$(Q)mv xentoollog.ml.tmp xentoollog.ml
+
+xentoollog.mli: xentoollog.mli.in _xtl_levels.mli.in
+	$(Q)sed -e '1i\
+(*\
+ * AUTO-GENERATED FILE DO NOT EDIT\
+ * Generated from xentoollog.mli.in and _xtl_levels.mli.in\
+ *)\
+' \
+	    -e '/^(\* @@XTL_LEVELS@@ \*)$$/r_xtl_levels.mli.in' \
+	  < xentoollog.mli.in > xentoollog.mli.tmp
+	$(Q)mv xentoollog.mli.tmp xentoollog.mli
+
+libs: $(LIBS)
+
+_xtl_levels.ml.in _xtl_levels.mli.in _xtl_levels.inc: genlevels.py $(XEN_ROOT)/tools/libxc/xentoollog.h
+	$(PYTHON) genlevels.py _xtl_levels.mli.in _xtl_levels.ml.in _xtl_levels.inc
+
+.PHONY: install
+install: $(LIBS) META
+	mkdir -p $(OCAMLDESTDIR)
+	ocamlfind remove -destdir $(OCAMLDESTDIR) xentoollog
+	ocamlfind install -destdir $(OCAMLDESTDIR) -ldconf ignore xentoollog META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+	ocamlfind remove -destdir $(OCAMLDESTDIR) xentoollog
+
+include $(TOPLEVEL)/Makefile.rules
diff --git a/tools/ocaml/libs/xentoollog/caml_xentoollog.h b/tools/ocaml/libs/xentoollog/caml_xentoollog.h
new file mode 100644
index 0000000..0eb7618
--- /dev/null
+++ b/tools/ocaml/libs/xentoollog/caml_xentoollog.h
@@ -0,0 +1,24 @@
+/*
+ * Copyright (C) 2013      Citrix Ltd.
+ * Author Ian Campbell <ian.campbell@citrix.com>
+ * Author Rob Hoes <rob.hoes@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.
+ */
+
+struct caml_xtl {
+	xentoollog_logger vtable;
+	char *vmessage_cb;
+	char *progress_cb;
+};
+
+#define Xtl_val(x)(*((struct caml_xtl **) Data_custom_val(x)))
+
diff --git a/tools/ocaml/libs/xentoollog/genlevels.py b/tools/ocaml/libs/xentoollog/genlevels.py
new file mode 100755
index 0000000..6b42f21
--- /dev/null
+++ b/tools/ocaml/libs/xentoollog/genlevels.py
@@ -0,0 +1,127 @@
+#!/usr/bin/python
+
+import sys
+
+def read_levels():
+	f = open('../../../libxc/xentoollog.h', 'r')
+
+	levels = []
+	record = False
+	for l in f.readlines():
+		if 'XTL_NUM_LEVELS' in l:
+			break
+		if record == True:
+			levels.append(l.split(',')[0].strip())
+		if 'XTL_NONE' in l:
+			record = True
+
+	f.close()
+
+	olevels = [level[4:].capitalize() for level in levels]
+
+	return levels, olevels
+
+# .ml
+
+def gen_ml(olevels):
+	s = ""
+
+	s += "type level = \n"
+	for level in olevels:
+		s += '\t| %s\n' % level
+
+	s += "\nlet level_to_string level =\n"
+	s +=  "\tmatch level with\n"
+	for level in olevels:
+		s += '\t| %s -> "%s"\n' % (level, level)
+
+	s += "\nlet level_to_prio level =\n"
+	s += "\tmatch level with\n"
+	for index,level in enumerate(olevels):
+		s += '\t| %s -> %d\n' % (level, index)
+
+	return s
+
+# .mli
+
+def gen_mli(olevels):
+	s = ""
+
+	s += "type level = \n"
+	for level in olevels:
+		s += '\t| %s\n' % level
+
+	return s
+
+# .c
+
+def gen_c(level):
+	s = ""
+
+	s += "static value Val_level(xentoollog_level c_level)\n"
+	s += "{\n"
+	s += "\tswitch (c_level) {\n"
+	s += "\tcase XTL_NONE: /* Not a real value */\n"
+	s += '\t\tcaml_raise_sys_error(caml_copy_string("Val_level XTL_NONE"));\n'
+	s += "\t\tbreak;\n"
+
+	for index,level in enumerate(levels):
+		s += "\tcase %s:\n\t\treturn Val_int(%d);\n" % (level, index)
+
+	s += """\tcase XTL_NUM_LEVELS: /* Not a real value! */
+	\t\tcaml_raise_sys_error(
+	\t\t\tcaml_copy_string("Val_level XTL_NUM_LEVELS"));
+	#if 0 /* Let the compiler catch this */
+	\tdefault:
+	\t\tcaml_raise_sys_error(caml_copy_string("Val_level Unknown"));
+	\t\tbreak;
+	#endif
+	\t}
+	\tabort();
+	}
+	"""
+
+	return s
+
+def autogen_header(open_comment, close_comment):
+    s = open_comment + " AUTO-GENERATED FILE DO NOT EDIT " + close_comment + "\n"
+    s += open_comment + " autogenerated by \n"
+    s += reduce(lambda x,y: x + " ", range(len(open_comment + " ")), "")
+    s += "%s" % " ".join(sys.argv)
+    s += "\n " + close_comment + "\n\n"
+    return s
+
+if __name__ == '__main__':
+	if len(sys.argv) < 3:
+		print >>sys.stderr, "Usage: genlevels.py <mli> <ml> <c-inc>"
+		sys.exit(1)
+
+	levels, olevels = read_levels()
+
+	_mli = sys.argv[1]
+	mli = open(_mli, 'w')
+	mli.write(autogen_header("(*", "*)"))
+
+	_ml = sys.argv[2]
+	ml = open(_ml, 'w')
+	ml.write(autogen_header("(*", "*)"))
+
+	_cinc = sys.argv[3]
+	cinc = open(_cinc, 'w')
+	cinc.write(autogen_header("/*", "*/"))
+
+	mli.write(gen_mli(olevels))
+	mli.write("\n")
+
+	ml.write(gen_ml(olevels))
+	ml.write("\n")
+
+	cinc.write(gen_c(levels))
+	cinc.write("\n")
+
+	ml.write("(* END OF AUTO-GENERATED CODE *)\n")
+	ml.close()
+	mli.write("(* END OF AUTO-GENERATED CODE *)\n")
+	mli.close()
+	cinc.close()
+
diff --git a/tools/ocaml/libs/xentoollog/xentoollog.ml.in b/tools/ocaml/libs/xentoollog/xentoollog.ml.in
new file mode 100644
index 0000000..ce9ea1d
--- /dev/null
+++ b/tools/ocaml/libs/xentoollog/xentoollog.ml.in
@@ -0,0 +1,48 @@
+(*
+ * Copyright (C) 2012      Citrix Ltd.
+ * Author Ian Campbell <ian.campbell@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 Random
+open Callback
+
+(* @@XTL_LEVELS@@ *)
+
+let compare_level x y =
+	compare (level_to_prio x) (level_to_prio y)
+
+type handle
+
+type logger_cbs = {
+	vmessage : level -> int option -> string option -> string -> unit;
+	progress : string option -> string -> int -> int64 -> int64 -> unit;
+	(*destroy : unit -> unit*)
+}
+
+external _create_logger: (string * string) -> handle = "stub_xtl_create_logger"
+external test: handle -> unit = "stub_xtl_test"
+
+let counter = ref 0L
+
+let create name cbs : handle =
+	(* Callback names are supposed to be unique *)
+	let suffix = Int64.to_string !counter in
+	counter := Int64.succ !counter;
+	let vmessage_name = sprintf "%s_vmessage_%s" name suffix in
+	let progress_name = sprintf "%s_progress_%s" name suffix in
+	(*let destroy_name = sprintf "%s_destroy" name in*)
+	Callback.register vmessage_name cbs.vmessage;
+	Callback.register progress_name cbs.progress;
+	_create_logger (vmessage_name, progress_name)
+
diff --git a/tools/ocaml/libs/xentoollog/xentoollog.mli.in b/tools/ocaml/libs/xentoollog/xentoollog.mli.in
new file mode 100644
index 0000000..05c098a
--- /dev/null
+++ b/tools/ocaml/libs/xentoollog/xentoollog.mli.in
@@ -0,0 +1,43 @@
+(*
+ * Copyright (C) 2012      Citrix Ltd.
+ * Author Ian Campbell <ian.campbell@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.
+ *)
+
+(* @@XTL_LEVELS@@ *)
+
+val level_to_string : level -> string
+val compare_level : level -> level -> int
+
+type handle
+
+(** call back arguments. See xentoollog.h for more info.
+    vmessage:
+      level: level as above
+      errno: Some <errno> or None
+      context: Some <string> or None
+      message: The log message (already formatted)
+    progress:
+      context: Some <string> or None
+      doing_what: string
+      percent, done, total.
+*)
+type logger_cbs = {
+	vmessage : level -> int option -> string option -> string -> unit;
+	progress : string option -> string -> int -> int64 -> int64 -> unit;
+	(*destroy : handle -> unit*)
+}
+
+external test: handle -> unit = "stub_xtl_test"
+
+val create : string -> logger_cbs -> handle
+
diff --git a/tools/ocaml/libs/xentoollog/xentoollog_stubs.c b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
new file mode 100644
index 0000000..3b2f91b
--- /dev/null
+++ b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c
@@ -0,0 +1,196 @@
+/*
+ * Copyright (C) 2012      Citrix Ltd.
+ * Author Ian Campbell <ian.campbell@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 _GNU_SOURCE
+#include <stdio.h>
+#include <string.h>
+#include <unistd.h>
+#include <errno.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 <caml/custom.h>
+
+#include <xentoollog.h>
+
+#include "caml_xentoollog.h"
+
+#define XTL ((xentoollog_logger *) Xtl_val(handle))
+
+static char * dup_String_val(value s)
+{
+	int len;
+	char *c;
+	len = caml_string_length(s);
+	c = calloc(len + 1, sizeof(char));
+	if (!c)
+		caml_raise_out_of_memory();
+	memcpy(c, String_val(s), len);
+	return c;
+}
+
+#include "_xtl_levels.inc"
+
+/* Option type support as per http://www.linux-nantes.org/~fmonnier/ocaml/ocaml-wrapping-c.php */
+#define Val_none Val_int(0)
+#define Some_val(v) Field(v,0)
+
+static value Val_some(value v)
+{
+	CAMLparam1(v);
+	CAMLlocal1(some);
+	some = caml_alloc(1, 0);
+	Store_field(some, 0, v);
+	CAMLreturn(some);
+}
+
+static value Val_errno(int errnoval)
+{
+	if (errnoval == -1)
+		return Val_none;
+	return Val_some(Val_int(errnoval));
+}
+
+static value Val_context(const char *context)
+{
+	if (context == NULL)
+		return Val_none;
+	return Val_some(caml_copy_string(context));
+}
+
+static void stub_xtl_ocaml_vmessage(struct xentoollog_logger *logger,
+	xentoollog_level level,
+	int errnoval,
+	const char *context,
+	const char *format,
+	va_list al)
+{
+	CAMLparam0();
+	CAMLlocalN(args, 4);
+	struct caml_xtl *xtl = (struct caml_xtl*)logger;
+	value *func = caml_named_value(xtl->vmessage_cb) ;
+	char *msg;
+
+	if (args == NULL)
+		caml_raise_out_of_memory();
+	if (func == NULL)
+		caml_raise_sys_error(caml_copy_string("Unable to find callback"));
+	if (vasprintf(&msg, format, al) < 0)
+		caml_raise_out_of_memory();
+
+	/* vmessage : level -> int option -> string option -> string -> unit; */
+	args[0] = Val_level(level);
+	args[1] = Val_errno(errnoval);
+	args[2] = Val_context(context);
+	args[3] = caml_copy_string(msg);
+
+	free(msg);
+
+	caml_callbackN(*func, 4, args);
+	CAMLreturn0;
+}
+
+static void stub_xtl_ocaml_progress(struct xentoollog_logger *logger,
+	const char *context,
+	const char *doing_what /* no \r,\n */,
+	int percent, unsigned long done, unsigned long total)
+{
+	CAMLparam0();
+	CAMLlocalN(args, 5);
+	struct caml_xtl *xtl = (struct caml_xtl*)logger;
+	value *func = caml_named_value(xtl->progress_cb) ;
+
+	if (args == NULL)
+		caml_raise_out_of_memory();
+	if (func == NULL)
+		caml_raise_sys_error(caml_copy_string("Unable to find callback"));
+
+	/* progress : string option -> string -> int -> int64 -> int64 -> unit; */
+	args[0] = Val_context(context);
+	args[1] = caml_copy_string(doing_what);
+	args[2] = Val_int(percent);
+	args[3] = caml_copy_int64(done);
+	args[4] = caml_copy_int64(total);
+
+	caml_callbackN(*func, 5, args);
+	CAMLreturn0;
+}
+
+static void xtl_destroy(struct xentoollog_logger *logger)
+{
+	struct caml_xtl *xtl = (struct caml_xtl*)logger;
+	free(xtl->vmessage_cb);
+	free(xtl->progress_cb);
+	free(xtl);
+}
+
+void xtl_finalize(value handle)
+{
+	xtl_destroy(XTL);
+}
+
+static struct custom_operations xentoollogger_custom_operations = {
+	"xentoollogger_custom_operations",
+	xtl_finalize /* custom_finalize_default */,
+	custom_compare_default,
+	custom_hash_default,
+	custom_serialize_default,
+	custom_deserialize_default
+};
+
+/* external _create_logger: (string * string) -> handle = "stub_xtl_create_logger" */
+CAMLprim value stub_xtl_create_logger(value cbs)
+{
+	CAMLparam1(cbs);
+	CAMLlocal1(handle);
+	struct caml_xtl *xtl = malloc(sizeof(*xtl));
+	if (xtl == NULL)
+		caml_raise_out_of_memory();
+
+	memset(xtl, 0, sizeof(*xtl));
+
+	xtl->vtable.vmessage = &stub_xtl_ocaml_vmessage;
+	xtl->vtable.progress = &stub_xtl_ocaml_progress;
+	xtl->vtable.destroy = &xtl_destroy;
+
+	xtl->vmessage_cb = dup_String_val(Field(cbs, 0));
+	xtl->progress_cb = dup_String_val(Field(cbs, 1));
+
+	handle = caml_alloc_custom(&xentoollogger_custom_operations, sizeof(xtl), 0, 1);
+	Xtl_val(handle) = xtl;
+
+	CAMLreturn(handle);
+}
+
+/* external test: handle -> unit = "stub_xtl_test" */
+CAMLprim value stub_xtl_test(value handle)
+{
+	unsigned long l;
+	CAMLparam1(handle);
+	xtl_log(XTL, XTL_DEBUG, -1, "debug", "%s -- debug", __func__);
+	xtl_log(XTL, XTL_INFO, -1, "test", "%s -- test 1", __func__);
+	xtl_log(XTL, XTL_INFO, ENOSYS, "test errno", "%s -- test 2", __func__);
+	xtl_log(XTL, XTL_CRITICAL, -1, "critical", "%s -- critical", __func__);
+	for (l = 0UL; l<=100UL; l += 10UL) {
+		xtl_progress(XTL, "progress", "testing", l, 100UL);
+		usleep(10000);
+	}
+	CAMLreturn(Val_unit);
+}
+
diff --git a/tools/ocaml/test/Makefile b/tools/ocaml/test/Makefile
new file mode 100644
index 0000000..980054c
--- /dev/null
+++ b/tools/ocaml/test/Makefile
@@ -0,0 +1,28 @@
+XEN_ROOT = $(CURDIR)/../../..
+OCAML_TOPLEVEL = $(CURDIR)/..
+include $(OCAML_TOPLEVEL)/common.make
+
+OCAMLINCLUDE += \
+	-I $(OCAML_TOPLEVEL)/libs/xentoollog
+
+OBJS = xtl
+
+PROGRAMS = xtl
+
+xtl_LIBS =  \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xentoollog $(OCAML_TOPLEVEL)/libs/xentoollog/xentoollog.cmxa \
+	-cclib -lxenctrl
+
+xtl_OBJS = xtl
+
+OCAML_PROGRAM = xtl
+
+all: $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+install: all
+	$(INSTALL_DIR) $(DESTDIR)$(BINDIR)
+	$(INSTALL_PROG) $(PROGRAMS) $(DESTDIR)$(BINDIR)
+
+include $(OCAML_TOPLEVEL)/Makefile.rules
diff --git a/tools/ocaml/test/xtl.ml b/tools/ocaml/test/xtl.ml
new file mode 100644
index 0000000..db30aae
--- /dev/null
+++ b/tools/ocaml/test/xtl.ml
@@ -0,0 +1,40 @@
+open Arg
+open Printf
+open Xentoollog
+
+let stdio_vmessage min_level level errno ctx msg =
+	let level_str = level_to_string level
+	and errno_str = match errno with None -> "" | Some s -> sprintf ": errno=%d" s
+	and ctx_str = match ctx with None -> "" | Some s -> sprintf ": %s" s in
+	if compare min_level level <= 0 then begin
+		printf "%s%s%s: %s\n" level_str ctx_str errno_str msg;
+		flush stdout;
+	end
+
+let stdio_progress ctx what percent dne total =
+	let nl = if dne = total then "\n" else "" in
+	printf "\rProgress %s %d%% (%Ld/%Ld)%s" what percent dne total nl;
+	flush stdout
+
+let create_stdio_logger ?(level=Info) () =
+	let cbs = {
+		vmessage = stdio_vmessage level;
+		progress = stdio_progress; } in
+	create "Xentoollog.stdio_logger" cbs
+
+let do_test level = 
+  let lgr = create_stdio_logger ~level:level () in
+  begin
+    test lgr;
+  end
+
+let () =
+  let debug_level = ref Info in
+  let speclist = [
+    ("-v", Arg.Unit (fun () -> debug_level := Debug), "Verbose");
+    ("-q", Arg.Unit (fun () -> debug_level := Critical), "Quiet");
+  ] in
+  let usage_msg = "usage: xtl [OPTIONS]" in
+  Arg.parse speclist (fun s -> ()) usage_msg;
+
+  do_test !debug_level
-- 
1.7.10.4