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
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
val name: string
end
-let hostname_cache = ref None
-let hostname_m = Mutex.create ()
-let get_hostname () =
- match Mutex.execute hostname_m (fun () -> !hostname_cache) with
- | Some h -> h
- | None ->
- let h = Unix.gethostname () in
- Mutex.execute hostname_m (fun () -> hostname_cache := Some h);
- h
-let invalidate_hostname_cache () = Mutex.execute hostname_m (fun () -> hostname_cache := None)
-
module Debugger = functor(Brand: BRAND) -> struct
+ let hostname = Unix.gethostname ()
let _ =
Mutex.execute dkmutex (fun () ->
debug_keys := StringSet.add Brand.name !debug_keys)
let output (f:string -> ?extra:string -> ('a, unit, string, 'b) format4 -> 'a) fmt =
let extra =
Printf.sprintf "%s|%s|%s|%s"
- (get_hostname ())
+ hostname
(get_thread_name ())
(get_task ())
Brand.name
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"
- (get_hostname ())
+ hostname
(get_thread_name ())
(get_task ())
Brand.name
(** Debug utilities *)
-(** Throw away the cached hostname. The next log line will re-query the hostname *)
-val invalidate_hostname_cache: unit -> unit
-
(** {2 Associate a task to the current actions} *)
(** Associate a task name to the current thread *)
*)
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
val log_and_return :
string ->
Log.level ->
- ?raw:bool -> syslog_time:bool -> ?extra:string -> ('a, unit, string, string) format4 -> 'a
+ ?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
external close : unit -> unit = "stub_closelog"
-val facility_of_string : string -> facility
projects / xcp / xen-api-libs.git / commitdiff