Commits

Dmitry Grebeniuk  committed 61d5557

logging module

  • Participants
  • Parent commits 8abc8bd

Comments (0)

Files changed (2)

File parvel_log.ml

+open Printf
+;
+
+type log_dest =
+  [ Channel of out_channel
+  | File of string
+  | Function of (string -> unit)
+  ]
+;
+
+type log_level = int
+;
+
+value log_level_debug = 1
+  and log_level_info = 2
+  and log_level_error = 3
+  and log_level_no = 4
+;
+
+(* with additional spaces *)
+value string_of_log_level = fun
+  [ 1 -> " debug   "
+  | 2 -> " info    "
+  | 3 -> " error   "
+  | _ -> assert False
+  ]
+;
+
+
+
+type log_dest_state =
+  [ LS_channel of out_channel
+  | LS_file of string and out_channel
+  | LS_function of (string -> unit)
+  ]
+;
+
+type log_state = (log_dest_state * log_dest * log_level)
+;
+
+
+(* author of original code: ygrek *)
+value time_to_buf ?(gmt=False) ?(ms=False) f buf =
+  let t = (if gmt then Unix.gmtime else Unix.localtime) f in
+  let sec =
+    if ms
+    then sprintf "%07.4f" (mod_float f 60.)
+    else sprintf "%02u" t.Unix.tm_sec
+  in
+    bprintf buf "%04u-%02u-%02uT%02u:%02u:%s%s"
+      (1900 + t.Unix.tm_year)
+      (t.Unix.tm_mon+1)
+      t.Unix.tm_mday
+      t.Unix.tm_hour
+      t.Unix.tm_min
+      sec
+      (if gmt then "Z" else "")
+;
+
+
+value log_gmt = True
+  and log_ms = True
+;
+
+value write log_state level line =
+  match log_state with
+  [ (cur_state, _cur_dest, cur_level) ->
+      if level < cur_level
+      then ()
+      else
+        let buf = Buffer.create 100 in
+        ( time_to_buf ~gmt:log_gmt ~ms:log_ms
+           (Unix.gettimeofday ()) buf
+        ; Buffer.add_string buf (string_of_log_level level)
+        ; Buffer.add_string buf line
+        ; match cur_state with
+          [ LS_channel c | LS_file _ c ->
+              ( Buffer.add_char buf '\n'
+              ; Buffer.output_buffer c buf
+              ; flush c
+              )
+          | LS_function f -> f (Buffer.contents buf)
+          ]
+        )
+  ]
+;
+
+
+value default_log_dest = Channel stderr
+  and default_log_level = log_level_no
+;
+
+value state_of_dest log_dest log_level =
+  ( match log_dest with
+    [ Channel c -> LS_channel c
+    | File fn ->
+        let c = open_out_gen
+          [ Open_append ; Open_creat ; Open_binary ]
+          0o666
+          fn
+        in
+          LS_file fn c
+    | Function f -> LS_function f
+    ]
+  , log_dest
+  , log_level
+  )
+;
+
+value cur_log_state = ref (state_of_dest default_log_dest default_log_level)
+;
+
+value debug fmt = ksprintf (write cur_log_state.val log_level_debug) fmt
+  and info fmt = ksprintf (write cur_log_state.val log_level_info) fmt
+  and error fmt = ksprintf (write cur_log_state.val log_level_error) fmt
+;
+
+value string_of_log_dest_state = fun
+  [ LS_channel _ -> "<channel>"
+  | LS_file fn _ -> sprintf "file %S" fn
+  | LS_function _ -> "<function>"
+  ]
+;
+
+
+value log_dest_finalize (cur_log_state, _cur_log_dest, _cur_log_level) =
+  match cur_log_state with
+  [ LS_channel _ | LS_function _ -> ()
+  | LS_file _fn c -> close_out c
+  ]
+;
+
+
+value set
+ : ?log_dest : log_dest -> ?log_level : log_level -> unit -> unit
+ = fun ?log_dest ?log_level () ->
+     let ((old_log_dest_state, old_log_dest, old_log_level) as old_log_state) =
+       cur_log_state.val in
+     let () = debug "stopping to log in %s"
+       (string_of_log_dest_state old_log_dest_state) in
+     let () = log_dest_finalize old_log_state in
+     let log_dest = match log_dest with
+       [ None -> old_log_dest | Some v -> v ]
+     and log_level = match log_level with
+       [ None -> old_log_level | Some v -> v ]
+     in
+     let ((new_log_dest_state, _, _) as new_log_state) =
+       state_of_dest log_dest log_level in
+     ( cur_log_state.val := new_log_state
+     ; debug "starting to log in %s"
+         (string_of_log_dest_state new_log_dest_state)
+     )
+;
+
+

File parvel_log.mli

+type log_dest =
+  [ Channel of out_channel
+  | File of string
+  | Function of (string -> unit)
+  ]
+;
+
+type log_level
+;
+
+value log_level_debug : log_level;
+value log_level_info : log_level;
+value log_level_error : log_level;
+value log_level_no : log_level;
+
+value set :?log_dest:log_dest -> ?log_level:log_level -> unit -> unit
+;
+
+
+value debug : format4 'a unit string unit -> 'a;
+value info : format4 'a unit string unit -> 'a;
+value error : format4 'a unit string unit -> 'a;