[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index] [Xen-changelog] [xen-unstable] ocaml: add logging bindings.
# 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
|
Lists.xenproject.org is hosted with RackSpace, monitoring our |