log.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011 Bert Burgemeister
   3 ;;;
   4 ;;; This program is free software; you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation; either version 2 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License along
  15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
  16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17
  18
  19 (in-package :phoros)
  20
  21 (cl-log:defcategory :db-sys)
  22 (cl-log:defcategory :db-dat)
  23 (cl-log:defcategory :server)
  24 (cl-log:defcategory :orphan)
  25 (cl-log:defcategory :error)
  26 (cl-log:defcategory :warning (or :warning :error))
  27 (cl-log:defcategory :db (or :db-sys :db-dat :warning :error))
  28 (cl-log:defcategory :debug (or :debug :db-sys :db-dat :server :orphan :warning :error))
  29
  30 (defun launch-logger (&optional (log-dir ""))
  31   "Start logging facility.  Create log-dir if necessary."
  32   (let ((log-dir (pathname-directory (ensure-directories-exist
  33                                       (pathname log-dir)))))
  34
  35     (setf (cl-log:log-manager)
  36           (make-instance 'cl-log:log-manager
  37                          :message-class 'cl-log:formatted-message))
  38
  39     (cl-log:start-messenger
  40      'cl-log:text-file-messenger
  41      :name :orphan
  42      :filename (make-pathname :directory log-dir :name "orphans" :type "log")
  43      :category :orphan)
  44
  45     (cl-log:start-messenger
  46      'cl-log:text-file-messenger
  47      :name :debug
  48      :filename (make-pathname :directory log-dir :name "debug" :type "log")
  49      :category :debug)
  50
  51     (cl-log:start-messenger
  52      'cl-log:text-file-messenger
  53      :name :warning
  54      :filename (make-pathname :directory log-dir :name "warnings" :type "log")
  55      :category :warning)
  56
  57     (cl-log:start-messenger
  58      'cl-log:text-file-messenger
  59      :name :db
  60      :filename (make-pathname :directory log-dir :name "phoros" :type "log")
  61      :category :db)
  62
  63     (cl-log:start-messenger
  64      'cl-log:text-stream-messenger
  65      :name :stream
  66      :stream *error-output*
  67      :category :debug)))
  68
  69
  70 (defmethod cl-log:format-message ((self cl-log:formatted-message))
  71   (format nil "~A ~A ~?~&"
  72           (timestring (cl-log:timestamp-universal-time
  73                        (cl-log:message-timestamp self)))
  74           (cl-log:message-category self)
  75           (cl-log:message-description self)
  76           (cl-log:message-arguments self)))
  77
  78 (defun timestring (time)
  79   "ISO 8601 representation of time."
  80   (multiple-value-bind (whole-seconds remainder) (floor time)
  81     (when (zerop remainder) (setf remainder nil))
  82     (multiple-value-bind (second minute hour date month year)
  83         (decode-universal-time whole-seconds 0)
  84       (format
  85        nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~@[~0F~]Z"
  86        year month date hour minute second remainder))))