From: David Scott Date: Mon, 26 Oct 2009 16:32:15 +0000 (+0000) Subject: [refactoring] move debug.ml from xen-api.hg to xen-api-libs.hg/log X-Git-Url: http://xenbits.xensource.com/gitweb?a=commitdiff_plain;h=0a8e0966bd292cb3691791025ea12db22bf49893;p=xcp%2Fxen-api-libs.git [refactoring] move debug.ml from xen-api.hg to xen-api-libs.hg/log Signed-off-by: Thomas Gazagnaire --- diff --git a/log/META.in b/log/META.in index 5c3646a..98f0c4c 100644 --- a/log/META.in +++ b/log/META.in @@ -1,4 +1,5 @@ version = "@VERSION@" description = "Log - logging library" +requires = "unix,stdext" archive(byte) = "log.cma" archive(native) = "log.cmxa" diff --git a/log/Makefile b/log/Makefile index be0719a..28d9fb6 100644 --- a/log/Makefile +++ b/log/Makefile @@ -15,8 +15,8 @@ OCAMLABI := $(shell ocamlc -version) 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) @@ -38,32 +38,25 @@ libsyslog_stubs.a: syslog_stubs.o 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 diff --git a/log/debug.ml b/log/debug.ml index 092b13e..bdd43e8 100644 --- a/log/debug.ml +++ b/log/debug.ml @@ -22,6 +22,11 @@ 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 @@ -76,18 +81,8 @@ module type BRAND = sig 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) @@ -107,7 +102,7 @@ module Debugger = functor(Brand: BRAND) -> struct 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 @@ -117,7 +112,7 @@ module Debugger = functor(Brand: BRAND) -> struct 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 diff --git a/log/debug.mli b/log/debug.mli index 2f2b53c..22e0013 100644 --- a/log/debug.mli +++ b/log/debug.mli @@ -14,9 +14,6 @@ (** 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 *) diff --git a/log/log.ml b/log/log.ml index ad7e10c..3d3b0e4 100644 --- a/log/log.ml +++ b/log/log.ml @@ -13,7 +13,15 @@ *) 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 @@ -64,6 +72,12 @@ let mkdir_rec dir perm = 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 = @@ -134,7 +148,7 @@ let close t = | 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 @@ -148,7 +162,7 @@ let string_of_logger t = 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 diff --git a/log/log.mli b/log/log.mli index 607b7b5..3eb1a1c 100644 --- a/log/log.mli +++ b/log/log.mli @@ -11,46 +11,90 @@ * 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 +*) diff --git a/log/logs.ml b/log/logs.ml index 94a8a38..8adac3d 100644 --- a/log/logs.ml +++ b/log/logs.ml @@ -41,7 +41,7 @@ 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 + let t = Log.of_string logstring in Hashtbl.add __all_loggers logstring t; t diff --git a/log/logs.mli b/log/logs.mli index 3a44eee..0aa701e 100644 --- a/log/logs.mli +++ b/log/logs.mli @@ -33,7 +33,7 @@ val log : 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 diff --git a/log/syslog.mli b/log/syslog.mli index 7ff2cda..eabafb8 100644 --- a/log/syslog.mli +++ b/log/syslog.mli @@ -39,4 +39,3 @@ external log : facility -> level -> string -> unit = "stub_syslog" external close : unit -> unit = "stub_closelog" -val facility_of_string : string -> facility