helm/uwobo/uwobo_logger.ml

   1 (*
   2  * Copyright (C) 2003:
   3  *    Stefano Zacchiroli <zack@cs.unibo.it>
   4  *    for the HELM Team http://helm.cs.unibo.it/
   5  *
   6  *  This file is part of HELM, an Hypertextual, Electronic
   7  *  Library of Mathematics, developed at the Computer Science
   8  *  Department, University of Bologna, Italy.
   9  *
  10  *  HELM is free software; you can redistribute it and/or
  11  *  modify it under the terms of the GNU General Public License
  12  *  as published by the Free Software Foundation; either version 2
  13  *  of the License, or (at your option) any later version.
  14  *
  15  *  HELM is distributed in the hope that it will be useful,
  16  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  17  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18  *  GNU General Public License for more details.
  19  *
  20  *  You should have received a copy of the GNU General Public License
  21  *  along with HELM; if not, write to the Free Software
  22  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  23  *  MA  02111-1307, USA.
  24  *
  25  *  For details, see the HELM World-Wide-Web page,
  26  *  http://helm.cs.unibo.it/
  27  *)
  28
  29 open Printf;;
  30
  31 type priority = [
  32   `Emerg | `Alert | `Crit | `Err | `Warning | `Notice | `Info | `Debug
  33 ]
  34
  35 let int_of_priority = function
  36   | `Emerg    -> 0
  37   | `Alert    -> 1
  38   | `Crit     -> 2
  39   | `Err      -> 3
  40   | `Warning  -> 4
  41   | `Notice   -> 5
  42   | `Info     -> 6
  43   | `Debug    -> 7
  44
  45 let string_of_priority = function
  46   | `Emerg    -> "EMERGENCY"
  47   | `Alert    -> "ALERT"
  48   | `Crit     -> "CRITICAL"
  49   | `Err      -> "ERROR"
  50   | `Warning  -> "WARNING"
  51   | `Notice   -> "NOTICE"
  52   | `Info     -> "INFO"
  53   | `Debug    -> "DEBUG"
  54
  55 class sysLogger ?(level: priority = `Notice) ?(outchan = stderr) () =
  56   object (self)
  57     val level_no = int_of_priority level
  58     val mutable enabled = false
  59     method level = level
  60     method levelNo = level_no
  61     method enable = enabled <- true
  62     method disable = enabled <- false
  63     method log (prio: priority) msg =
  64       let tm = Unix.localtime (Unix.time ()) in
  65       if enabled && (int_of_priority prio <= level_no) then begin
  66         fprintf outchan ("[UWOBO %02d/%02d/%4d %02d:%02d:%02d] %s: %s\n")
  67           tm.Unix.tm_mday (tm.Unix.tm_mon + 1) (tm.Unix.tm_year + 1900)
  68           tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
  69           (string_of_priority prio) msg;
  70         flush outchan
  71       end
  72   end
  73
  74 type lineType =
  75   | Line of string        (** normal line *)
  76   | LineBold of string    (** bold line *)
  77   | LineEmph of string    (** emph line *)
  78 ;;
  79
  80   (** non thread safe, a processingLogger is usually instantied locally for each
  81   thread *)
  82 class processingLogger =
  83   let html_escape = Netencoding.Html.encode ~in_enc:`Enc_iso88591 () in
  84   let html_of_line = function
  85     | Line l -> html_escape l
  86     | LineBold l -> "<b>" ^ html_escape l ^ "</b>"
  87     | LineEmph l -> "<em>" ^ html_escape l ^ "</em>"
  88   in
  89   let text_of_line = function
  90     | Line l -> l
  91     | LineBold l -> l
  92     | LineEmph l -> l
  93   in
  94   fun () ->
  95   object
  96     val mutable log_lines = []
  97     method log msg = log_lines <- Line msg :: log_lines
  98     method logBold msg = log_lines <- LineBold msg :: log_lines
  99     method logEmph msg = log_lines <- LineEmph msg :: log_lines
 100     method asText =
 101       String.concat "\n" (List.rev (List.map text_of_line log_lines))
 102     method asHtml =
 103       sprintf
 104         "<html><body>\n%s\n</body></html>"
 105         (String.concat "<br />\n" (List.map html_of_line (List.rev log_lines)))
 106   end
 107