Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
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@citrix.com> Signed-off-by: Rob Hoes <rob.hoes@citrix.com>
- Loading branch information
Showing
12 changed files
with
461 additions
and
2 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -3,6 +3,7 @@ include $(XEN_ROOT)/tools/Rules.mk | |
|
||
SUBDIRS= \ | ||
mmap \ | ||
xentoollog \ | ||
xc eventchn \ | ||
xb xs xl | ||
|
||
|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,4 @@ | ||
version = "@VERSION@" | ||
description = "Xen Tools Logger Interface" | ||
archive(byte) = "xentoollog.cma" | ||
archive(native) = "xentoollog.cmxa" |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,102 @@ | ||
(* | ||
* 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 | ||
|
||
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 | ||
|
||
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 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_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 | ||
|
||
external destroy: handle -> unit = "stub_xtl_destroy" |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,54 @@ | ||
(* | ||
* 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. | ||
*) | ||
|
||
type level = Debug | ||
| Verbose | ||
| Detail | ||
| Progress (* also used for "progress" messages *) | ||
| Info | ||
| Notice | ||
| Warn | ||
| Error | ||
| Critical | ||
|
||
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 | ||
|
||
val create_stdio_logger : ?level:level -> unit -> handle | ||
|
||
external destroy: handle -> unit = "stub_xtl_destroy" |
Oops, something went wrong.