%.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
SUBDIRS= \
mmap \
+ xentoollog \
xc eventchn \
xb xs xl
--- /dev/null
+version = "@VERSION@"
+description = "Xen Tools Logger Interface"
+archive(byte) = "xentoollog.cma"
+archive(native) = "xentoollog.cmxa"
--- /dev/null
+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
--- /dev/null
+/*
+ * 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)))
+
--- /dev/null
+#!/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()
+
--- /dev/null
+(*
+ * 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)
+
--- /dev/null
+(*
+ * 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
+
--- /dev/null
+/*
+ * 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);
+}
+
projects / xen.git / commitdiff