|
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index] [Xen-devel] [PATCH 10 of 15] libxc/ocaml: Add simple binding for xentoollog (output only)
# HG changeset patch
# User Ian Campbell <ijc@xxxxxxxxxxxxxx>
# Date 1353432141 0
# Node ID 2b433b1523e4295bb1ed74a7b71e2a20e00f1802
# Parent 5173d29f64fa541f6ec0c48481c4957a03f0302c
libxc/ocaml: Add simple binding for xentoollog (output only).
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@xxxxxxxxxx>
diff -r 5173d29f64fa -r 2b433b1523e4 .gitignore
--- a/.gitignore Tue Nov 20 17:22:21 2012 +0000
+++ b/.gitignore Tue Nov 20 17:22:21 2012 +0000
@@ -364,6 +364,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 -r 5173d29f64fa -r 2b433b1523e4 .hgignore
--- a/.hgignore Tue Nov 20 17:22:21 2012 +0000
+++ b/.hgignore Tue Nov 20 17:22:21 2012 +0000
@@ -305,6 +305,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 -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/Makefile
--- a/tools/ocaml/Makefile Tue Nov 20 17:22:21 2012 +0000
+++ b/tools/ocaml/Makefile Tue Nov 20 17:22:21 2012 +0000
@@ -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 -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/Makefile.rules
--- a/tools/ocaml/Makefile.rules Tue Nov 20 17:22:21 2012 +0000
+++ b/tools/ocaml/Makefile.rules Tue Nov 20 17:22:21 2012 +0000
@@ -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 -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/libs/Makefile
--- a/tools/ocaml/libs/Makefile Tue Nov 20 17:22:21 2012 +0000
+++ b/tools/ocaml/libs/Makefile Tue Nov 20 17:22:21 2012 +0000
@@ -3,6 +3,7 @@ include $(XEN_ROOT)/tools/Rules.mk
SUBDIRS= \
mmap \
+ xentoollog \
xc eventchn \
xb xs xl
diff -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/libs/xentoollog/META.in
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xentoollog/META.in Tue Nov 20 17:22:21 2012 +0000
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Xen Tools Logger Interface"
+archive(byte) = "xentoollog.cma"
+archive(native) = "xentoollog.cmxa"
diff -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/libs/xentoollog/Makefile
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xentoollog/Makefile Tue Nov 20 17:22:21 2012 +0000
@@ -0,0 +1,33 @@
+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
+
+all: $(INTF) $(LIBS)
+
+libs: $(LIBS)
+
+.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 -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/libs/xentoollog/xentoollog.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xentoollog/xentoollog.ml Tue Nov 20 17:22:21 2012 +0000
@@ -0,0 +1,101 @@
+(*
+ * Copyright (C) 2012 Citrix Ltd.
+ * Author Ian Campbell <ian.campbell@xxxxxxxxxx>
+ *
+ * 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
+
+type level = Debug
+ | Verbose
+ | Detail
+ | Progress
+ | Info
+ | Notice
+ | Warn
+ | Error
+ | Critical
+
+let level_to_string level =
+ match level with
+ | Debug -> "Debug"
+ | Verbose -> "Verbose"
+ | Detail -> "Detail"
+ | Progress -> "Progress"
+ | Info -> "Info"
+ | Notice -> "Notice"
+ | Warn -> "Warn"
+ | Error -> "Error"
+ | Critical -> "Critical"
+
+let level_to_prio level =
+ match level with
+ | Debug -> 0
+ | Verbose -> 1
+ | Detail -> 2
+ | Progress -> 3
+ | Info -> 4
+ | Notice -> 5
+ | Warn -> 6
+ | Error -> 7
+ | Critical -> 8
+
+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 create name cbs : handle =
+ (* Callback names are supposed to be unique *)
+ let suffix = string_of_int (Random.int 1000000) in
+ 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*)
+ begin
+ Callback.register vmessage_name cbs.vmessage;
+ Callback.register progress_name cbs.progress;
+ _create_logger (vmessage_name, progress_name)
+ end
+
+
+let stdio_vmessage min_level level errno ctx msg =
+ let level_int = level_to_prio level
+ and 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 min_level <= level_int 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 level_int = level_to_prio level in
+ let cbs = {
+ vmessage = stdio_vmessage level_int;
+ progress = stdio_progress; } in
+ create "Xentoollog.stdio_logger" cbs
+
+external destroy: handle -> unit = "stub_xtl_destroy"
diff -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/libs/xentoollog/xentoollog.mli
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xentoollog/xentoollog.mli Tue Nov 20 17:22:21
2012 +0000
@@ -0,0 +1,52 @@
+(*
+ * Copyright (C) 2012 Citrix Ltd.
+ * Author Ian Campbell <ian.campbell@xxxxxxxxxx>
+ *
+ * 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 = Debug
+ | Verbose
+ | Detail
+ | Progress (* also used for "progress" messages *)
+ | Info
+ | Notice
+ | Warn
+ | Error
+ | Critical
+
+val level_to_string : level -> string
+
+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
+
+val create_stdio_logger : ?level:level -> unit -> handle
+
+external destroy: handle -> unit = "stub_xtl_destroy"
diff -r 5173d29f64fa -r 2b433b1523e4
tools/ocaml/libs/xentoollog/xentoollog_stubs.c
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/xentoollog/xentoollog_stubs.c Tue Nov 20 17:22:21
2012 +0000
@@ -0,0 +1,211 @@
+/*
+ * Copyright (C) 2012 Citrix Ltd.
+ * Author Ian Campbell <ian.campbell@xxxxxxxxxx>
+ *
+ * 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 <xentoollog.h>
+
+struct caml_xtl {
+ xentoollog_logger vtable;
+ char *vmessage_cb;
+ char *progress_cb;
+};
+
+#define HND ((struct caml_xtl*)handle)
+#define XTL ((xentoollog_logger *)HND)
+
+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;
+}
+
+static value Val_level(xentoollog_level c_level)
+{
+ /* Must correspond to order in .mli */
+ switch (c_level) {
+ case XTL_NONE: /* Not a real value */
+ caml_raise_sys_error(caml_copy_string("Val_level XTL_NONE"));
+ break;
+ case XTL_DEBUG: return Val_int(0);
+ case XTL_VERBOSE: return Val_int(1);
+ case XTL_DETAIL: return Val_int(2);
+ case XTL_PROGRESS: return Val_int(3);
+ case XTL_INFO: return Val_int(4);
+ case XTL_NOTICE: return Val_int(5);
+ case XTL_WARN: return Val_int(6);
+ case XTL_ERROR: return Val_int(7);
+ case XTL_CRITICAL: return Val_int(8);
+ case XTL_NUM_LEVELS: /* Not a real value! */
+ caml_raise_sys_error(
+ caml_copy_string("Val_level XTL_NUM_LEVELS"));
+#if 0 /* Let the compiler catch this */
+ default:
+ caml_raise_sys_error(caml_copy_string("Val_level Unknown"));
+ break;
+#endif
+ }
+ abort();
+}
+
+/* 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)
+{
+ struct caml_xtl *xtl = (struct caml_xtl*)logger;
+ value *func = caml_named_value(xtl->vmessage_cb) ;
+ value args[4];
+ 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);
+}
+
+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)
+{
+ struct caml_xtl *xtl = (struct caml_xtl*)logger;
+ value *func = caml_named_value(xtl->progress_cb) ;
+ value args[5];
+
+ 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);
+}
+
+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);
+}
+
+/* external _create_logger: (string * string) -> handle =
"stub_xtl_create_logger" */
+CAMLprim value stub_xtl_create_logger(value cbs)
+{
+ CAMLparam1(cbs);
+ 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));
+ CAMLreturn((value)xtl);
+}
+
+/* external destroy: handle -> unit = "stub_xtl_destroy" */
+CAMLprim value stub_xtl_destroy(value handle)
+{
+ CAMLparam1(handle);
+ xtl_logger_destroy(XTL);
+ CAMLreturn(Val_unit);
+}
+
+/* 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 -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/test/Makefile
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/test/Makefile Tue Nov 20 17:22:21 2012 +0000
@@ -0,0 +1,27 @@
+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
+
+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 -r 5173d29f64fa -r 2b433b1523e4 tools/ocaml/test/xtl.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/test/xtl.ml Tue Nov 20 17:22:21 2012 +0000
@@ -0,0 +1,20 @@
+open Arg
+open Xentoollog
+
+let do_test level =
+ let lgr = Xentoollog.create_stdio_logger ~level:level () in
+ begin
+ Xentoollog.test lgr;
+ Xentoollog.destroy lgr;
+ end
+
+let () =
+ let debug_level = ref Xentoollog.Info in
+ let speclist = [
+ ("-v", Arg.Unit (fun () -> debug_level := Xentoollog.Debug), "Verbose");
+ ("-q", Arg.Unit (fun () -> debug_level := Xentoollog.Critical), "Quiet");
+ ] in
+ let usage_msg = "usage: xtl [OPTIONS]" in
+ Arg.parse speclist (fun s -> ()) usage_msg;
+
+ do_test !debug_level
_______________________________________________
Xen-devel mailing list
Xen-devel@xxxxxxxxxxxxx
http://lists.xen.org/xen-devel
|
 |
Lists.xenproject.org is hosted with RackSpace, monitoring our |