version = "@VERSION@"
description = "Log - logging library"
+requires = "unix,stdext"
archive(byte) = "log.cma"
archive(native) = "log.cmxa"
OCAMLLIBDIR := $(shell ocamlc -where)
OCAMLDESTDIR ?= $(OCAMLLIBDIR)
-OBJS = syslog log logs
-INTF = log.cmi logs.cmi syslog.cmi
+OBJS = syslog log logs debug
+INTF = log.cmi logs.cmi syslog.cmi debug.cmi
LIBS = log.cma log.cmxa
all: $(INTF) $(LIBS) $(PROGRAMS)
ar rcs $@ $+
ocamlmklib -o syslog_stubs $+
-%.cmo: %.ml
- $(OCAMLC) -c $(OCAMLCFLAGS) -o $@ $<
-
%.cmi: %.mli
$(OCAMLC) -c $(OCAMLCFLAGS) -o $@ $<
-%.cmx: %.ml
- $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
+%.cmo: %.ml %.cmi
+ $(OCAMLC) -c $(OCAMLCFLAGS) -thread -o $@ $<
+
+%.cmx: %.ml %.cmi
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -thread -c -o $@ $<
%.o: %.c
$(CC) $(CFLAGS) -c -o $@ $<
-logs.mli : logs.ml
- $(OCAMLC) -i $(OCAMLCFLAGS) $< > $@
-
-syslog.mli : syslog.ml
- $(OCAMLC) -i $< > $@
-
META: META.in
sed 's/@VERSION@/$(VERSION)/g' < $< > $@
#dependency:
-log.cmo: syslog.cmo log.cmi
-log.cmx: syslog.cmx log.cmi
-logs.cmo: log.cmi
-logs.cmx: log.cmx
+log.cmi: syslog.cmi
+logs.cmi: log.cmi
+debug.cmi: logs.cmi
.PHONY: install
install: $(LIBS) META
--- /dev/null
+(*
+ * Copyright (C) 2006-2009 Citrix Systems Inc.
+ *
+ * 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 Stringext
+open Pervasiveext
+open Threadext
+
+(** Associate a task with each active thread *)
+let thread_tasks : (int, string) Hashtbl.t = Hashtbl.create 256
+let thread_tasks_m = Mutex.create ()
+
+let get_thread_id () =
+ try Thread.id (Thread.self ()) with _ -> -1
+
+(* Theses functions need to be defined later in the code. *)
+let get_hostname =
+ let f () = "Debug.get_hostname not set" in
+ ref f
+
+let associate_thread_with_task task =
+ let id = get_thread_id () in
+ if id <> -1
+ then begin
+ Mutex.execute thread_tasks_m (fun () -> Hashtbl.add thread_tasks id task);
+ end
+
+let get_task_from_thread () =
+ let id = get_thread_id () in
+ Mutex.execute thread_tasks_m
+ (fun () -> if Hashtbl.mem thread_tasks id then Some(Hashtbl.find thread_tasks id) else None)
+
+let dissociate_thread_from_task () =
+ let id = get_thread_id () in
+ if id <> -1
+ then match get_task_from_thread () with
+ | Some _ ->
+ Mutex.execute thread_tasks_m (fun () -> Hashtbl.remove thread_tasks id)
+ | None ->
+ let extra = Printf.sprintf "[thread: debug (%n)] " id in
+ Logs.info ~extra "debug" "Thread id %d is not associated with any task" id
+
+let with_thread_associated task f x =
+ associate_thread_with_task task;
+ finally
+ (fun () -> f x)
+ dissociate_thread_from_task
+
+let threadnames = Hashtbl.create 256
+let tnmutex = Mutex.create ()
+module StringSet = Set.Make(struct type t=string let compare=Pervasives.compare end)
+let debug_keys = ref StringSet.empty
+let get_all_debug_keys () =
+ StringSet.fold (fun key keys -> key::keys) !debug_keys []
+
+let dkmutex = Mutex.create ()
+
+let _ = Hashtbl.add threadnames (-1) "no thread"
+
+let get_thread_id () =
+ try Thread.id (Thread.self ()) with _ -> -1
+
+let name_thread name =
+ let id = get_thread_id () in
+ Mutex.execute tnmutex (fun () -> Hashtbl.add threadnames id name)
+
+let remove_thread_name () =
+ let id = get_thread_id () in
+ Mutex.execute tnmutex (fun () -> Hashtbl.remove threadnames id)
+
+module type BRAND = sig
+ val name: string
+end
+
+module Debugger = functor(Brand: BRAND) -> struct
+ let hostname = Unix.gethostname ()
+ let _ =
+ Mutex.execute dkmutex (fun () ->
+ debug_keys := StringSet.add Brand.name !debug_keys)
+
+ let get_thread_name () =
+ let id = get_thread_id () in
+ Mutex.execute tnmutex
+ (fun () ->
+ try
+ Printf.sprintf "%d %s" id (Hashtbl.find threadnames id)
+ with _ ->
+ Printf.sprintf "%d" id)
+
+ let get_task () =
+ default "" (may (fun s -> s) (get_task_from_thread ()))
+
+ let output (f:string -> ?extra:string -> ('a, unit, string, 'b) format4 -> 'a) fmt =
+ let extra =
+ Printf.sprintf "%s|%s|%s|%s"
+ hostname
+ (get_thread_name ())
+ (get_task ())
+ Brand.name
+ in
+ f Brand.name ~extra fmt
+
+ let output_and_return ?raw (f:string -> ?raw:bool -> ?extra:string -> ('a, unit, string, 'b) format4 -> 'a) fmt =
+ let extra =
+ Printf.sprintf "%s|%s|%s|%s"
+ hostname
+ (get_thread_name ())
+ (get_task ())
+ Brand.name
+ in
+ f Brand.name ?raw ~extra fmt
+
+ let debug fmt = output Logs.debug fmt
+ let warn fmt = output Logs.warn fmt
+ let info fmt = output Logs.info fmt
+ let error fmt = output Logs.error fmt
+ let audit ?raw fmt = output_and_return ?raw Logs.audit fmt
+
+ let log_backtrace () =
+ let backtrace = Backtrace.get_backtrace () in
+ debug "%s" (String.escaped backtrace)
+
+end
--- /dev/null
+(*
+ * Copyright (C) 2006-2009 Citrix Systems Inc.
+ *
+ * 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.
+ *)
+
+(** Debug utilities *)
+
+(** {2 Associate a task to the current actions} *)
+
+(** Associate a task name to the current thread *)
+val associate_thread_with_task : string -> unit
+
+(** Dissociate a task name to the current thread *)
+val dissociate_thread_from_task : unit -> unit
+
+(** Do an action with a task name associated with the current thread *)
+val with_thread_associated : string -> ('a -> 'b) -> 'a -> 'b
+
+(** {2 Associate a name to the current thread} *)
+
+val name_thread : string -> unit
+
+val remove_thread_name : unit -> unit
+
+val get_all_debug_keys : unit -> string list
+
+module type BRAND = sig val name : string end
+
+module Debugger : functor (Brand : BRAND) ->
+sig
+
+ (** Debug function *)
+ val debug : ('a, unit, string, unit) format4 -> 'a
+
+ (** Warn function *)
+ val warn : ('a, unit, string, unit) format4 -> 'a
+
+ (** Info function *)
+ val info : ('a, unit, string, unit) format4 -> 'a
+
+ (** Error function *)
+ val error : ('a, unit, string, unit) format4 -> 'a
+
+ (** Audit function *)
+ val audit : ?raw:bool -> ('a, unit, string, string) format4 -> 'a
+
+ val log_backtrace : unit -> unit
+end
+
*)
open Printf
-open Threadext
+
+module Mutex = struct
+ include Mutex
+ let execute lock f =
+ Mutex.lock lock;
+ let r = begin try f () with exn -> Mutex.unlock lock; raise exn end; in
+ Mutex.unlock lock;
+ r
+end
exception Unknown_level of string
type t = { output: output; mutable level: level; }
+let get_strings t = match t.output with
+ | String s -> !s
+ | _ -> []
+
+let get_level t = t.level
+
let make output level = { output = output; level = level; }
let make_stream ty channel =
| String _ -> ()
(** create a string representating the parameters of the logger *)
-let string_of_logger t =
+let to_string t =
match t.output with
| Nil -> "nil"
| Syslog k -> sprintf "syslog:%s" k
end
(** parse a string to a logger *)
-let logger_of_string s : t =
+let of_string s : t =
match s with
| "nil" -> opennil ()
| "stderr" -> openerr Debug
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
-exception Unknown_level of string
+
+(** Logging utilities *)
+
+type t
+
+(** create a string representating the parameters of the logger *)
+val to_string : t -> string
+
+(** parse a string to a logger *)
+val of_string : string -> t
+
+(** try to reopen a logger *)
+val reopen : t -> t
+
+(** close a logger *)
+val close : t -> unit
+
+val gettimestring : unit -> string
+
+(** {2 Builders} *)
+
type level = Debug | Info | Warn | Error
+val get_level : t -> level
-type stream_type = Stderr | Stdout | File of string
-type stream_log = {
- ty : stream_type;
- channel : out_channel option ref;
- mutex : Mutex.t;
-}
-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
+exception Unknown_level of 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 string_of_level : level -> string
+
+(** open a syslog logger *)
val opensyslog : string -> level -> t
+
+(** open a stderr logger *)
val openerr : level -> t
+
+(** open a stdout logger *)
val openout : level -> t
+
+(** open a stream logger - returning the output type *)
val openfile : string -> level -> t
+
+(** open a nil logger *)
val opennil : unit -> t
+
+(** open a string logger *)
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 filesize : int ref
-val mutex : Mutex.t
+val get_strings : t -> string list
+
+(** {2 Raw output functions} *)
+
val output : t -> ?key:string -> ?extra:string -> level -> string -> unit
val output_and_return : t -> ?raw:bool -> ?key:string -> ?extra:string -> level -> string -> string
-val log : t -> level -> ('a, unit, string, unit) format4 -> 'a
+
+(** {2 Pretty output functions} *)
+
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
+val log : t -> level -> ('a, unit, string, unit) format4 -> 'a
+
+(** {2 Output validation} *)
+
+val validate : string -> unit
+
+(** {2 Concurrency} *)
+
+(** TODO: It would be very nice to have a thread-free log module (ie. put the control outside that module).
+ This mutex protects all the recorded outputs. *)
+val mutex : Mutex.t
+
+(** TODO: remove the global state (what happens if multiple log files are opened???) ! *)
+val filesize : int ref
+
+(*
+type stream_type = Stderr | Stdout | File of string
+type stream_log = {
+ ty : stream_type;
+ channel : out_channel option ref;
+ mutex : Mutex.t;
+}
+
+val int_of_level : level -> int
+val mkdir_safe : string -> Unix.file_perm -> unit
+val mkdir_rec : string -> Unix.file_perm -> unit
+val set : t -> level -> unit
+val mutex : Mutex.t
+*)
if Hashtbl.mem __all_loggers logstring then
Hashtbl.find __all_loggers logstring
else
- let t = Log.logger_of_string logstring in
+ let t = Log.of_string logstring in
Hashtbl.add __all_loggers logstring t;
t
--- /dev/null
+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_common :
+ string ->
+ Log.level ->
+ ?extra:string ->
+ ret_fn1:(string -> 'a) ->
+ ret_fn2:(Log.t list -> 'b) -> ('b, unit, string, 'a) format4 -> 'b
+val log :
+ string ->
+ Log.level -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+val log_and_return :
+ string ->
+ Log.level ->
+ ?raw:bool -> ?extra:string -> ('a, unit, string, string) 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
+val audit :
+ string ->
+ ?raw:bool -> ?extra:string -> ('a, unit, string, string) format4 -> 'a
--- /dev/null
+(*
+ * Copyright (C) 2006-2009 Citrix Systems Inc.
+ *
+ * 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 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"
+
+
projects / xcp / xen-api-libs.git / commitdiff