[PATCH 05/10] add logs ocaml bindings

[Vincent Hanquez <vincent.hanquez@eu.citrix.com>]

[-- Attachment #1: Type: text/plain, Size: 1105 bytes --]


Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
 tools/ocaml/libs/log/META.in        |    4 +
 tools/ocaml/libs/log/Makefile       |   41 ++++++
 tools/ocaml/libs/log/log.ml         |  258 +++++++++++++++++++++++++++++++++++
 tools/ocaml/libs/log/log.mli        |   55 ++++++++
 tools/ocaml/libs/log/logs.ml        |  197 ++++++++++++++++++++++++++
 tools/ocaml/libs/log/logs.mli       |   46 ++++++
 tools/ocaml/libs/log/syslog.ml      |   26 ++++
 tools/ocaml/libs/log/syslog.mli     |   41 ++++++
 tools/ocaml/libs/log/syslog_stubs.c |   73 ++++++++++
 9 files changed, 741 insertions(+), 0 deletions(-)
 create mode 100644 tools/ocaml/libs/log/META.in
 create mode 100644 tools/ocaml/libs/log/Makefile
 create mode 100644 tools/ocaml/libs/log/log.ml
 create mode 100644 tools/ocaml/libs/log/log.mli
 create mode 100644 tools/ocaml/libs/log/logs.ml
 create mode 100644 tools/ocaml/libs/log/logs.mli
 create mode 100644 tools/ocaml/libs/log/syslog.ml
 create mode 100644 tools/ocaml/libs/log/syslog.mli
 create mode 100644 tools/ocaml/libs/log/syslog_stubs.c


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0005-add-logs-ocaml-bindings.patch --]
[-- Type: text/x-patch; name="0005-add-logs-ocaml-bindings.patch", Size: 26619 bytes --]

diff --git a/tools/ocaml/libs/log/META.in b/tools/ocaml/libs/log/META.in
new file mode 100644
index 0000000..5c3646a
--- /dev/null
+++ b/tools/ocaml/libs/log/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Log - logging library"
+archive(byte) = "log.cma"
+archive(native) = "log.cmxa"
diff --git a/tools/ocaml/libs/log/Makefile b/tools/ocaml/libs/log/Makefile
new file mode 100644
index 0000000..47c7918
--- /dev/null
+++ b/tools/ocaml/libs/log/Makefile
@@ -0,0 +1,41 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OBJS = syslog log logs
+INTF = log.cmi logs.cmi syslog.cmi
+LIBS = log.cma log.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+log.cmxa: libsyslog_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
+	$(call mk-caml-lib-native, $@, -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmx))
+
+log.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+	$(call mk-caml-lib-bytecode, $@, -dllib dllsyslog_stubs.so -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmo))
+
+syslog_stubs.a: syslog_stubs.o
+	$(call mk-caml-stubs, $@, $+)
+
+libsyslog_stubs.a: syslog_stubs.o
+	$(call mk-caml-lib-stubs, $@, $+)
+
+logs.mli : logs.ml
+	$(OCAMLC) -i $(OCAMLCFLAGS) $< > $@
+
+syslog.mli : syslog.ml
+	$(OCAMLC) -i $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+	ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore log META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+	ocamlfind remove log
+
+include $(TOPLEVEL)/Makefile.rules
+
diff --git a/tools/ocaml/libs/log/log.ml b/tools/ocaml/libs/log/log.ml
new file mode 100644
index 0000000..4f42759
--- /dev/null
+++ b/tools/ocaml/libs/log/log.ml
@@ -0,0 +1,258 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.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
+
+exception Unknown_level of string
+
+type stream_type = Stderr | Stdout | File of string
+
+type stream_log = {
+  ty : stream_type;
+  channel : out_channel option ref;
+}
+
+type level = Debug | Info | Warn | Error
+
+type output =
+	| Stream of stream_log
+	| String of string list ref
+	| Syslog of string
+	| Nil
+
+let int_of_level l =
+	match l with Debug -> 0 | Info -> 1 | Warn -> 2 | Error -> 3
+
+let string_of_level l =
+	match l with Debug -> "debug" | Info -> "info"
+	           | Warn -> "warn" | Error -> "error"
+
+let level_of_string s =
+	match s with
+	| "debug" -> Debug
+	| "info"  -> Info
+	| "warn"  -> Warn
+	| "error" -> Error
+	| _       -> raise (Unknown_level s)
+
+let mkdir_safe dir perm =
+        try Unix.mkdir dir perm with _ -> ()
+
+let mkdir_rec dir perm =
+	let rec p_mkdir dir =
+		let p_name = Filename.dirname dir in
+		if p_name = "/" || p_name = "." then
+			()
+		else (
+			p_mkdir p_name;
+			mkdir_safe dir perm
+		) in
+	p_mkdir dir
+
+type t = { output: output; mutable level: level; }
+
+let make output level = { output = output; level = level; }
+
+let make_stream ty channel = 
+        Stream {ty=ty; channel=ref channel; }
+
+(** open a syslog logger *)
+let opensyslog k level =
+	make (Syslog k) level
+
+(** open a stderr logger *)
+let openerr level =
+	if (Unix.stat "/dev/stderr").Unix.st_kind <> Unix.S_CHR then
+		failwith "/dev/stderr is not a valid character device";
+	make (make_stream Stderr (Some (open_out "/dev/stderr"))) level
+	
+let openout level =
+	if (Unix.stat "/dev/stdout").Unix.st_kind <> Unix.S_CHR then
+		failwith "/dev/stdout is not a valid character device";
+        make (make_stream Stdout (Some (open_out "/dev/stdout"))) level
+
+
+(** open a stream logger - returning the channel. *)
+(* This needs to be separated from 'openfile' so we can reopen later *)
+let doopenfile filename =
+        if Filename.is_relative filename then
+	        None
+	else (
+                try
+		  mkdir_rec (Filename.dirname filename) 0o700;
+	          Some (open_out_gen [ Open_append; Open_creat ] 0o600 filename)
+                with _ -> None
+	)
+
+(** open a stream logger - returning the output type *)
+let openfile filename level =
+        make (make_stream (File filename) (doopenfile filename)) level
+
+(** open a nil logger *)
+let opennil () =
+	make Nil Error
+
+(** open a string logger *)
+let openstring level =
+        make (String (ref [""])) level
+
+(** try to reopen a logger *)
+let reopen t =
+	match t.output with
+	| Nil              -> t
+	| Syslog k         -> Syslog.close (); opensyslog k t.level
+	| Stream s         -> (
+	      match (s.ty,!(s.channel)) with 
+		| (File filename, Some c) -> close_out c; s.channel := (try doopenfile filename with _ -> None); t 
+		| _ -> t)
+	| String _         -> t
+
+(** close a logger *)
+let close t =
+	match t.output with
+	| Nil           -> ()
+	| Syslog k      -> Syslog.close ();
+	| Stream s      -> (
+	      match !(s.channel) with 
+		| Some c -> close_out c; s.channel := None
+		| None -> ())
+	| String _      -> ()
+
+(** create a string representating the parameters of the logger *)
+let string_of_logger t =
+	match t.output with
+	| Nil           -> "nil"
+	| Syslog k      -> sprintf "syslog:%s" k
+	| String _      -> "string"
+	| Stream s      -> 
+	    begin
+	      match s.ty with 
+		| File f -> sprintf "file:%s" f
+		| Stderr -> "stderr"
+		| Stdout -> "stdout"
+	    end
+
+(** parse a string to a logger *)
+let logger_of_string s : t =
+	match s with
+	| "nil"    -> opennil ()
+	| "stderr" -> openerr Debug
+	| "stdout" -> openout Debug
+	| "string" -> openstring Debug
+	| _        ->
+		let split_in_2 s =
+			try
+				let i = String.index s ':' in
+				String.sub s 0 (i),
+				String.sub s (i + 1) (String.length s - i - 1)
+			with _ ->
+				failwith "logger format error: expecting string:string"
+			in
+		let k, s = split_in_2 s in
+		match k with
+		| "syslog" -> opensyslog s Debug
+		| "file"   -> openfile s Debug
+		| _        -> failwith "unknown logger type"
+
+let validate s =
+	match s with
+	| "nil"    -> ()
+	| "stderr" -> ()
+	| "stdout" -> ()
+	| "string" -> ()
+	| _        ->
+		let split_in_2 s =
+			try
+				let i = String.index s ':' in
+				String.sub s 0 (i),
+				String.sub s (i + 1) (String.length s - i - 1)
+			with _ ->
+				failwith "logger format error: expecting string:string"
+			in
+		let k, s = split_in_2 s in
+		match k with
+		| "syslog" -> ()
+		| "file"   -> (
+			try
+				let st = Unix.stat s in
+				if st.Unix.st_kind <> Unix.S_REG then
+					failwith "logger file is a directory";
+				()
+			with Unix.Unix_error (Unix.ENOENT, _, _) -> ()
+			)
+		| _        -> failwith "unknown logger"
+
+(** change a logger level to level *)
+let set t level = t.level <- level
+
+let gettimestring () =
+	let time = Unix.gettimeofday () in
+	let tm = Unix.localtime time in
+        let msec = time -. (floor time) in
+	sprintf "%d%.2d%.2d %.2d:%.2d:%.2d.%.3d|" (1900 + tm.Unix.tm_year)
+	        (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
+	        tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
+	        (int_of_float (1000.0 *. msec))
+
+(*let extra_hook = ref (fun x -> x)*)
+
+let output t ?(key="") ?(extra="") priority (message: string) =
+  let construct_string withtime =
+		(*let key = if key = "" then [] else [ key ] in
+		let extra = if extra = "" then [] else [ extra ] in
+		let items = 
+      (if withtime then [ gettimestring () ] else [])
+		  @ [ sprintf "%5s" (string_of_level priority) ] @ extra @ key @ [ message ] in
+(*		let items = !extra_hook items in*)
+		String.concat " " items*)
+    Printf.sprintf "[%s%s|%s] %s" 
+      (if withtime then gettimestring () else "") (string_of_level priority) extra message
+	in
+	(* Keep track of how much we write out to streams, so that we can *)
+	(* log-rotate at appropriate times *)
+	let write_to_stream stream =
+	  let string = (construct_string true) in
+	  try
+	    fprintf stream "%s\n%!" string
+	  with _ -> () (* Trap exception when we fail to write log *)
+        in
+
+	if String.length message > 0 then
+	match t.output with
+	| Syslog k      ->
+		let sys_prio = match priority with
+		| Debug -> Syslog.Debug
+		| Info  -> Syslog.Info
+		| Warn  -> Syslog.Warning
+		| Error -> Syslog.Err in
+		Syslog.log Syslog.Daemon sys_prio ((construct_string false) ^ "\n")
+	| Stream s -> (
+	      match !(s.channel) with
+		| Some c -> write_to_stream c
+		| None -> ())
+	| Nil           -> ()
+	| String s      -> (s := (construct_string true)::!s)
+
+let log t level (fmt: ('a, unit, string, unit) format4): 'a =
+	let b = (int_of_level t.level) <= (int_of_level level) in
+	(* ksprintf is the preferred name for kprintf, but the former
+	 * is not available in OCaml 3.08.3 *)
+	Printf.kprintf (if b then output t level else (fun _ -> ())) fmt
+	    
+let debug t (fmt: ('a , unit, string, unit) format4) = log t Debug fmt
+let info t (fmt: ('a , unit, string, unit) format4) = log t Info fmt
+let warn t (fmt: ('a , unit, string, unit) format4) = log t Warn fmt
+let error t (fmt: ('a , unit, string, unit) format4) = log t Error fmt
diff --git a/tools/ocaml/libs/log/log.mli b/tools/ocaml/libs/log/log.mli
new file mode 100644
index 0000000..36c5a6b
--- /dev/null
+++ b/tools/ocaml/libs/log/log.mli
@@ -0,0 +1,55 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.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.
+ *)
+
+exception Unknown_level of string
+type level = Debug | Info | Warn | Error
+
+type stream_type = Stderr | Stdout | File of string
+type stream_log = {
+  ty : stream_type;
+  channel : out_channel option ref;
+}
+type output =
+    Stream of stream_log
+  | String of string list ref
+  | Syslog of string
+  | Nil
+val int_of_level : level -> int
+val string_of_level : level -> string
+val level_of_string : string -> level
+val mkdir_safe : string -> Unix.file_perm -> unit
+val mkdir_rec : string -> Unix.file_perm -> unit
+type t = { output : output; mutable level : level; }
+val make : output -> level -> t
+val opensyslog : string -> level -> t
+val openerr : level -> t
+val openout : level -> t
+val openfile : string -> level -> t
+val opennil : unit -> t
+val openstring : level -> t
+val reopen : t -> t
+val close : t -> unit
+val string_of_logger : t -> string
+val logger_of_string : string -> t
+val validate : string -> unit
+val set : t -> level -> unit
+val gettimestring : unit -> string
+val output : t -> ?key:string -> ?extra:string -> level -> string -> unit
+val log : t -> level -> ('a, unit, string, unit) format4 -> 'a
+val debug : t -> ('a, unit, string, unit) format4 -> 'a
+val info : t -> ('a, unit, string, unit) format4 -> 'a
+val warn : t -> ('a, unit, string, unit) format4 -> 'a
+val error : t -> ('a, unit, string, unit) format4 -> 'a
diff --git a/tools/ocaml/libs/log/logs.ml b/tools/ocaml/libs/log/logs.ml
new file mode 100644
index 0000000..2a40896
--- /dev/null
+++ b/tools/ocaml/libs/log/logs.ml
@@ -0,0 +1,197 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.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 keylogger =
+{
+	mutable debug: string list;
+	mutable info: string list;
+	mutable warn: string list;
+	mutable error: string list;
+	no_default: bool;
+}
+
+(* map all logger strings into a logger *)
+let __all_loggers = Hashtbl.create 10
+
+(* default logger that everything that doesn't have a key in __lop_mapping get send *)
+let __default_logger = { debug = []; info = []; warn = []; error = []; no_default = false }
+
+(*
+ * This describe the mapping between a name to a keylogger.
+ * a keylogger contains a list of logger string per level of debugging.
+ * Example:   "xenops", debug -> [ "stderr"; "/var/log/xensource.log" ]
+ *            "xapi", error ->   []
+ *            "xapi", debug ->   [ "/var/log/xensource.log" ]
+ *            "xenops", info ->  [ "syslog" ]
+ *)
+let __log_mapping = Hashtbl.create 32
+
+let get_or_open logstring =
+	if Hashtbl.mem __all_loggers logstring then
+		Hashtbl.find __all_loggers logstring
+	else
+		let t = Log.logger_of_string logstring in
+		Hashtbl.add __all_loggers logstring t;
+		t
+
+(** create a mapping entry for the key "name".
+ * all log level of key "name" default to "logger" logger.
+ * a sensible default is put "nil" as a logger and reopen a specific level to
+ * the logger you want to.
+ *)
+let add key logger =
+	let kl = {
+		debug = logger;
+		info = logger;
+		warn = logger;
+		error = logger;
+		no_default = false;
+	} in
+	Hashtbl.add __log_mapping key kl
+
+let get_by_level keylog level =
+	match level with
+	| Log.Debug -> keylog.debug
+	| Log.Info  -> keylog.info
+	| Log.Warn  -> keylog.warn
+	| Log.Error -> keylog.error
+
+let set_by_level keylog level logger =
+	match level with
+	| Log.Debug -> keylog.debug <- logger
+	| Log.Info  -> keylog.info <- logger
+	| Log.Warn  -> keylog.warn <- logger
+	| Log.Error -> keylog.error <- logger
+
+(** set a specific key|level to the logger "logger" *)
+let set key level logger =
+	if not (Hashtbl.mem __log_mapping key) then
+		add key [];
+
+	let keylog = Hashtbl.find __log_mapping key in
+	set_by_level keylog level logger
+
+(** set default logger *)
+let set_default level logger =
+	set_by_level __default_logger level logger
+
+(** append a logger to the list *)
+let append key level logger =
+	if not (Hashtbl.mem __log_mapping key) then
+		add key [];
+	let keylog = Hashtbl.find __log_mapping key in
+	let loggers = get_by_level keylog level in
+	set_by_level keylog level (loggers @ [ logger ])
+
+(** append a logger to the default list *)
+let append_default level logger =
+	let loggers = get_by_level __default_logger level in
+	set_by_level __default_logger level (loggers @ [ logger ])
+
+(** reopen all logger open *)
+let reopen () =
+	Hashtbl.iter (fun k v ->
+		Hashtbl.replace __all_loggers k (Log.reopen v)) __all_loggers
+
+(** reclaim close all logger open that are not use by any other keys *)
+let reclaim () =
+	let list_sort_uniq l =
+		let oldprev = ref "" and prev = ref "" in
+		List.fold_left (fun a k ->
+			oldprev := !prev;
+			prev := k;
+			if k = !oldprev then a else k :: a) []
+			(List.sort compare l)
+		in
+	let flatten_keylogger v =
+		list_sort_uniq (v.debug @ v.info @ v.warn @ v.error) in
+	let oldkeys = Hashtbl.fold (fun k v a -> k :: a) __all_loggers [] in
+	let usedkeys = Hashtbl.fold (fun k v a ->
+		(flatten_keylogger v) @ a)
+		__log_mapping (flatten_keylogger __default_logger) in
+	let usedkeys = list_sort_uniq usedkeys in
+
+	List.iter (fun k ->
+		if not (List.mem k usedkeys) then (
+			begin try
+				Log.close (Hashtbl.find __all_loggers k)
+			with
+				Not_found -> ()
+			end;
+			Hashtbl.remove __all_loggers k
+		)) oldkeys
+
+(** clear a specific key|level *)
+let clear key level =
+	try
+		let keylog = Hashtbl.find __log_mapping key in
+		set_by_level keylog level [];
+		reclaim ()
+	with Not_found ->
+		()
+
+(** clear a specific default level *)
+let clear_default level =
+	set_default level [];
+	reclaim ()
+
+(** reset all the loggers to the specified logger *)
+let reset_all logger =
+	Hashtbl.clear __log_mapping;
+	set_default Log.Debug logger;
+	set_default Log.Warn logger;
+	set_default Log.Error logger;
+	set_default Log.Info logger;
+	reclaim ()
+
+(** log a fmt message to the key|level logger specified in the log mapping.
+ * if the logger doesn't exist, assume nil logger.
+ *)
+let log key level ?(extra="") (fmt: ('a, unit, string, unit) format4): 'a =
+	let keylog =
+		if Hashtbl.mem __log_mapping key then
+			let keylog = Hashtbl.find __log_mapping key in
+			if keylog.no_default = false &&
+			   get_by_level keylog level = [] then
+				__default_logger
+			else
+				keylog
+		else
+			__default_logger in
+	let loggers = get_by_level keylog level in
+	match loggers with
+	| [] -> Printf.kprintf ignore fmt
+	| _  ->
+		let l = List.fold_left (fun acc logger ->	
+			try get_or_open logger :: acc
+			with _ -> acc
+		) [] loggers in
+		let l = List.rev l in
+
+		(* ksprintf is the preferred name for kprintf, but the former
+		 * is not available in OCaml 3.08.3 *)
+		Printf.kprintf (fun s ->
+			List.iter (fun t -> Log.output t ~key ~extra level s) l) fmt
+
+(* define some convenience functions *)
+let debug t ?extra (fmt: ('a , unit, string, unit) format4) =
+	log t Log.Debug ?extra fmt
+let info t ?extra (fmt: ('a , unit, string, unit) format4) =
+	log t Log.Info ?extra fmt
+let warn t ?extra (fmt: ('a , unit, string, unit) format4) =
+	log t Log.Warn ?extra fmt
+let error t ?extra (fmt: ('a , unit, string, unit) format4) =
+	log t Log.Error ?extra fmt
diff --git a/tools/ocaml/libs/log/logs.mli b/tools/ocaml/libs/log/logs.mli
new file mode 100644
index 0000000..76e10db
--- /dev/null
+++ b/tools/ocaml/libs/log/logs.mli
@@ -0,0 +1,46 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.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 keylogger = {
+  mutable debug : string list;
+  mutable info : string list;
+  mutable warn : string list;
+  mutable error : string list;
+  no_default : bool;
+}
+val __all_loggers : (string, Log.t) Hashtbl.t
+val __default_logger : keylogger
+val __log_mapping : (string, keylogger) Hashtbl.t
+val get_or_open : string -> Log.t
+val add : string -> string list -> unit
+val get_by_level : keylogger -> Log.level -> string list
+val set_by_level : keylogger -> Log.level -> string list -> unit
+val set : string -> Log.level -> string list -> unit
+val set_default : Log.level -> string list -> unit
+val append : string -> Log.level -> string -> unit
+val append_default : Log.level -> string -> unit
+val reopen : unit -> unit
+val reclaim : unit -> unit
+val clear : string -> Log.level -> unit
+val clear_default : Log.level -> unit
+val reset_all : string list -> unit
+val log :
+  string ->
+  Log.level -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+val debug : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+val info : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+val warn : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+val error : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
diff --git a/tools/ocaml/libs/log/syslog.ml b/tools/ocaml/libs/log/syslog.ml
new file mode 100644
index 0000000..2b417da
--- /dev/null
+++ b/tools/ocaml/libs/log/syslog.ml
@@ -0,0 +1,26 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.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 = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug
+type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid
+type facility = Auth | Authpriv | Cron | Daemon | Ftp | Kern
+              | Local0 | Local1 | Local2 | Local3
+	      | Local4 | Local5 | Local6 | Local7
+	      | Lpr | Mail | News | Syslog | User | Uucp
+
+(* external init : string -> options list -> facility -> unit = "stub_openlog" *)
+external log : facility -> level -> string -> unit = "stub_syslog"
+external close : unit -> unit = "stub_closelog"
diff --git a/tools/ocaml/libs/log/syslog.mli b/tools/ocaml/libs/log/syslog.mli
new file mode 100644
index 0000000..425f42a
--- /dev/null
+++ b/tools/ocaml/libs/log/syslog.mli
@@ -0,0 +1,41 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.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 = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug
+type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid
+type facility =
+    Auth
+  | Authpriv
+  | Cron
+  | Daemon
+  | Ftp
+  | Kern
+  | Local0
+  | Local1
+  | Local2
+  | Local3
+  | Local4
+  | Local5
+  | Local6
+  | Local7
+  | Lpr
+  | Mail
+  | News
+  | Syslog
+  | User
+  | Uucp
+external log : facility -> level -> string -> unit = "stub_syslog"
+external close : unit -> unit = "stub_closelog"
diff --git a/tools/ocaml/libs/log/syslog_stubs.c b/tools/ocaml/libs/log/syslog_stubs.c
new file mode 100644
index 0000000..965610a
--- /dev/null
+++ b/tools/ocaml/libs/log/syslog_stubs.c
@@ -0,0 +1,73 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.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.
+ */
+
+#include <syslog.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+
+static int __syslog_level_table[] = {
+	LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING,
+	LOG_NOTICE, LOG_INFO, LOG_DEBUG
+};
+
+static int __syslog_options_table[] = {
+	LOG_CONS, LOG_NDELAY, LOG_NOWAIT, LOG_ODELAY, LOG_PERROR, LOG_PID
+};
+
+static int __syslog_facility_table[] = {
+	LOG_AUTH, LOG_AUTHPRIV, LOG_CRON, LOG_DAEMON, LOG_FTP, LOG_KERN,
+	LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3,
+	LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7,
+	LOG_LPR | LOG_MAIL | LOG_NEWS | LOG_SYSLOG | LOG_USER | LOG_UUCP
+};
+
+/* According to the openlog manpage the 'openlog' call may take a reference
+   to the 'ident' string and keep it long-term. This means we cannot just pass in
+   an ocaml string which is under the control of the GC. Since we aren't actually
+   calling this function we can just comment it out for the time-being. */
+/*
+value stub_openlog(value ident, value option, value facility)
+{
+	CAMLparam3(ident, option, facility);
+	int c_option;
+	int c_facility;
+
+	c_option = caml_convert_flag_list(option, __syslog_options_table);
+	c_facility = __syslog_facility_table[Int_val(facility)];
+	openlog(String_val(ident), c_option, c_facility);
+	CAMLreturn(Val_unit);
+}
+*/
+
+value stub_syslog(value facility, value level, value msg)
+{
+	CAMLparam3(facility, level, msg);
+	int c_facility;
+
+	c_facility = __syslog_facility_table[Int_val(facility)]
+	           | __syslog_level_table[Int_val(level)];
+	syslog(c_facility, "%s", String_val(msg));
+	CAMLreturn(Val_unit);
+}
+
+value stub_closelog(value unit)
+{
+	CAMLparam1(unit);
+	closelog();
+	CAMLreturn(Val_unit);
+}

[-- Attachment #3: Type: text/plain, Size: 138 bytes --]

_______________________________________________
Xen-devel mailing list
Xen-devel@lists.xensource.com
http://lists.xensource.com/xen-devel