mirror of
https://github.com/xen-project/xen.git
synced 2026-10-29 18:50:05 +01:00
Rob Hoes
65e35eb124
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>
[ ijc -- dropped the xtl test harness, it failed to link ]
49 lines
1.5 KiB
Plaintext
49 lines
1.5 KiB
Plaintext
(*
|
|
* 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)
|
|
|