# HG changeset patch
# User Keir Fraser <keir.fraser@xxxxxxxxxx>
# Date 1273140242 -3600
# Node ID 8281b2dde2cfd109aa7956a2fb0ede95b063b5e2
# Parent cad29ef535d61d6135dfbcbf12d2f15ac76fd048
ocaml: add logging bindings.
Signed-off-by: Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
---
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(+)
diff -r cad29ef535d6 -r 8281b2dde2cf tools/ocaml/libs/log/META.in
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/log/META.in Thu May 06 11:04:02 2010 +0100
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Log - logging library"
+archive(byte) = "log.cma"
+archive(native) = "log.cmxa"
diff -r cad29ef535d6 -r 8281b2dde2cf tools/ocaml/libs/log/Makefile
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/log/Makefile Thu May 06 11:04:02 2010 +0100
@@ -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 -r cad29ef535d6 -r 8281b2dde2cf tools/ocaml/libs/log/log.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/log/log.ml Thu May 06 11:04:02 2010 +0100
@@ -0,0 +1,258 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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 -r cad29ef535d6 -r 8281b2dde2cf tools/ocaml/libs/log/log.mli
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/log/log.mli Thu May 06 11:04:02 2010 +0100
@@ -0,0 +1,55 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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 -r cad29ef535d6 -r 8281b2dde2cf tools/ocaml/libs/log/logs.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/log/logs.ml Thu May 06 11:04:02 2010 +0100
@@ -0,0 +1,197 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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 -r cad29ef535d6 -r 8281b2dde2cf tools/ocaml/libs/log/logs.mli
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/log/logs.mli Thu May 06 11:04:02 2010 +0100
@@ -0,0 +1,46 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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 -r cad29ef535d6 -r 8281b2dde2cf tools/ocaml/libs/log/syslog.ml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/log/syslog.ml Thu May 06 11:04:02 2010 +0100
@@ -0,0 +1,26 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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 -r cad29ef535d6 -r 8281b2dde2cf tools/ocaml/libs/log/syslog.mli
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/log/syslog.mli Thu May 06 11:04:02 2010 +0100
@@ -0,0 +1,41 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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 -r cad29ef535d6 -r 8281b2dde2cf tools/ocaml/libs/log/syslog_stubs.c
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/ocaml/libs/log/syslog_stubs.c Thu May 06 11:04:02 2010 +0100
@@ -0,0 +1,73 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@xxxxxxxxxxxxx>
+ *
+ * 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);
+}
_______________________________________________
Xen-changelog mailing list
Xen-changelog@xxxxxxxxxxxxxxxxxxx
http://lists.xensource.com/xen-changelog
|
Home