;; -*- lisp -*-

(in-package :it.bese.arnesi)

;;;; * A Trivial logging facility

;;;; A logger is a way to have the system generate a text message and
;;;; have that messaged saved somewhere for future review. Logging can
;;;; be used as a debugging mechanism or for just reporting on the
;;;; status of a system.

;;;; Logs are sent to a particular log category, each log category
;;;; sends the messages it receives to its handlers. A handler's job
;;;; is to take a message and write it somewhere. Log categories are
;;;; organized in a hierarchy and messages sent to a log category will
;;;; also be sent to that category's ancestors.

;;;; Each log category has a log level which is used to determine
;;;; whether are particular message should be processed or
;;;; not. Categories inherit their log level from their ancestors. If a
;;;; category has multiple fathers its log level is the min of the
;;;; levels of its fathers.

;;;; ** Log Levels

(eval-always
  (defconstant +dribble+ 0)
  (defconstant +debug+   1)
  (defconstant +info+    2)
  (defconstant +warn+    3)
  (defconstant +error+   4)
  (defconstant +fatal+   5)

  (defparameter *log-level-names* (coerce '(+dribble+ +debug+ +info+ +warn+ +error+ +fatal+)
                                          'simple-vector))
  (deflookup-table logger))

(defun log-level-name-of (level)
  (when (not (<= 0 level #.(1- (length *log-level-names*))))
    (error "~S is an invalid log level" level))
  (aref *log-level-names* level))

;;;; ** Log Categories

(defclass log-category ()
  ((ancestors :initform '()     :accessor ancestors :initarg :ancestors
              :documentation "The log categories this category inherits from.")
   (children  :initform '()     :accessor children  :initarg :children
              :documentation "The log categories which inherit from this category.")
   (appenders :initform '()     :accessor appenders :initarg :appenders
              :documentation "A list of appender objects this category sholud send messages to.")
   (level     :initform nil :initarg :level :accessor level
              :type (or null integer)
              :documentation "This category's log level.")
   (compile-time-level
              :initform +dribble+ :initarg :compile-time-level :accessor compile-time-level
              :type integer
              :documentation "This category's compile time log level. Any log expression below this level will macro-expand to NIL.")
   (name      :initarg :name :accessor name)))

(defmethod make-load-form ((self log-category) &optional env)
  (declare (ignore env))
  `(let ((result (get-logger ',(name self))))
     (assert result)
     result))

(defmethod print-object ((category log-category) stream)
  (print-unreadable-object (category stream :type t :identity t)
    (format stream "~S ~a"
	    (if (slot-boundp category 'name)
		(name category)
		"#<NO NAME>")
	    (level category))))

(defmethod shared-initialize :after ((l log-category) slot-names
                                     &key ancestors &allow-other-keys)
  (declare (ignore slot-names))
  (dolist (anc ancestors)
    (pushnew l (children anc) :test (lambda (a b)
				     (eql (name a) (name b))))))

;;; Runtime levels
(defmethod enabled-p ((cat log-category) level)
  (>= level (log.level cat)))

(defmethod log.level ((cat log-category))
  (or (level cat)
      (if (ancestors cat)
          (loop for ancestor in (ancestors cat)
                minimize (log.level ancestor))
          (error "Can't determine level for ~S" cat))))

(defmethod log.level ((cat-name symbol))
  (log.level (get-logger cat-name)))

(defmethod (setf log.level) (new-level (cat log-category)
                             &optional (recursive t))
  "Change the log level of CAT to NEW-LEVEL. If RECUSIVE is T the
  setting is also applied to the sub categories of CAT."
  (setf (slot-value cat 'level) new-level)
  (when recursive
    (dolist (child (children cat))
      (setf (log.level child) new-level)))
  new-level)

(defmethod (setf log.level) (new-level (cat-name symbol) &optional (recursive t))
  (setf (log.level (get-logger cat-name) recursive) new-level))

(defmethod (setf log.level) (new-level (cat-name null) &optional (recursive t))
  (declare (ignore new-level cat-name recursive))
  (error "NIL does not specify a category."))

;;; Compile time levels
(defmethod compile-time-enabled-p ((cat log-category) level)
  (>= level (log.compile-time-level cat)))

(defmethod log.compile-time-level ((cat log-category))
  (or (compile-time-level cat)
      (if (ancestors cat)
          (loop for ancestor in (ancestors cat)
                minimize (log.compile-time-level ancestor))
          (error "Can't determine compile time level for ~S" cat))))

(defmethod log.compile-time-level ((cat-name symbol))
  (log.compile-time-level (get-logger cat-name)))

(defmethod (setf log.compile-time-level) (new-level (cat log-category)
                                          &optional (recursive t))
  "Change the compile time log level of CAT to NEW-LEVEL. If RECUSIVE is T the
  setting is also applied to the sub categories of CAT."
  (setf (slot-value cat 'compile-time-level) new-level)
  (when recursive
    (dolist (child (children cat))
      (setf (log.compile-time-level child) new-level)))
  new-level)

(defmethod (setf log.compile-time-level) (new-level (cat-name symbol) &optional (recursive t))
  (setf (log.compile-time-level (get-logger cat-name) recursive) new-level))

(defmethod (setf log.compile-time-level) (new-level (cat-name null) &optional (recursive t))
  (declare (ignore new-level cat-name recursive))
  (error "NIL does not specify a category."))

(defmacro with-logger-level (logger-name new-level &body body)
  "Set the level of the listed logger(s) to NEW-LEVEL and restore the original value in an unwind-protect."
  (cond ((consp logger-name)
         `(with-logger-level ,(pop logger-name) ,new-level
           ,(if logger-name
                `(with-logger-level ,logger-name ,new-level
                  ,@body)
                `(progn
                  ,@body))))
        ((symbolp logger-name)
         (with-unique-names (logger old-level)
           `(let* ((,logger (get-logger ',logger-name))
                   (,old-level (level ,logger)))
             (setf (level ,logger) ,new-level)
             (unwind-protect
                  (progn ,@body)
               (setf (level ,logger) ,old-level)))))
        (t (error "Don't know how to interpret ~S as a logger name" logger-name))))

;;;; ** Handling Messages

(defmacro with-logging-io (&body body)
  `(let ((*print-right-margin* most-positive-fixnum)
         (*print-readably* nil)
         (*print-length* 64)
         (*package* #+ecl (find-package "COMMON-LISP")
                    #-ecl #.(find-package "COMMON-LISP")))
    ,@body))

(defgeneric handle (category message level)
  (:documentation "Message is either a string or a list. When it's a list and the first element is a string then it's processed as args to cl:format."))

(defmethod handle :around ((cat log-category) message level)
  ;; turn off line wrapping for the entire time while inside the loggers
  (with-logging-io
    (call-next-method)))

(defmethod handle ((cat log-category) message level)
  (labels ((do-appenders (ac)
	     ;; if we have any appenders send them the message
	     (awhen (appenders ac)
	       (dolist (appender it)
		 (append-message cat appender message level)))

	     ;; send the message to our ancestors	     
	     (mapc #'do-appenders (ancestors ac))))
    (do-appenders cat)))

(defgeneric append-message (category log-appender message level)
  (:method :around (category log-appender message level)
    ;; what else should we do?
    (ignore-errors
      (call-next-method))))

;;;; *** Stream log appender

(defclass appender ()
  ((verbosity :initform 2 :initarg :verbosity :accessor verbosity-of)))
  
(defclass stream-log-appender (appender)
  ((stream :initarg :stream :accessor log-stream))
  (:documentation "Human readable to the console logger."))

(defmethod make-instance ((class (eql (find-class 'stream-log-appender)))
                          &rest initargs)
  (declare (ignore initargs))
  (error "STREAM-LOG-APPENDER is an abstract class. You must use either brief-stream-log-appender or verbose-stream-log-appender objects."))

(defmethod append-message :around (category (appender stream-log-appender) (message cons) level)
  (append-message category appender (apply #'format nil message) level))

(defclass brief-stream-log-appender (stream-log-appender)
  ((last-message-year :initform 0)
   (last-message-month :initform 0)
   (last-message-day :initform 0))
  (:documentation "A subclass of stream-log-appender with minimal
  'overhead' text in log messages. This amounts to: not printing
  the package names of log categories and log levels and a more
  compact printing of the current time."))

(defclass verbose-stream-log-appender (stream-log-appender)
  ()
  (:documentation "A subclass of stream-log-appender which
  attempts to be as precise as possible, category names and log
  level names are printed with a package prefix and the time is
  printed in long format."))

(defmethod append-message :around ((category log-category) (s stream-log-appender)
                                   message level)
  (restart-case
      (call-next-method)
    (use-*debug-io* ()
      :report "Use the current value of *debug-io*"
      (setf (log-stream s) *debug-io*)
      (append-message category s message level))
    (use-*standard-output* ()
      :report "Use the current value of *standard-output*"
      (setf (log-stream s) *standard-output*)
      (append-message category s message level))
    (silence-logger ()
      :report "Ignore all future messages to this logger."
      (setf (log-stream s) (make-broadcast-stream)))))

(eval-always
  (defparameter *max-category-name-length* 12))

(defmethod append-message ((category log-category) (s brief-stream-log-appender)
                           message level)
  (multiple-value-bind (second minute hour day month year)
      (decode-universal-time (get-universal-time))
    (declare (ignore second))
    (with-slots (last-message-year last-message-month last-message-day)
        s
      (unless (and (= year last-message-year)
                   (= month last-message-month)
                   (= day last-message-day))
        (format (log-stream s) "--TIME MARK ~4,'0D-~2,'0D-~2,'0D--~%"
                year month day)
        (setf last-message-year year
              last-message-month month
              last-message-day day)))
    (let* ((category-name (symbol-name (name category)))
           (level-name (symbol-name level))
           (category-length (length category-name)))
      (format (log-stream s)
              #.(strcat "~2,'0D:~2,'0D ~"
                        *max-category-name-length*
                        "@A ~7A ")
              hour minute
              (subseq category-name
                      (max 0 (- category-length
                                *max-category-name-length*))
                      category-length)
              (subseq level-name 1 (1- (length level-name)))))
    (format (log-stream s) "~A~%" message)))

(defmethod append-message ((category log-category) (s verbose-stream-log-appender)
                            message level)
  (multiple-value-bind (second minute hour date month year)
      (decode-universal-time (get-universal-time))
    (format (log-stream s)
            "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D.~2,'0D ~A/~A: "
            year month date hour minute second
            (name category) level)
    (format (log-stream s) "~A~%" message)))

(defun make-stream-log-appender (&rest args &key (stream *debug-io*) (verbosity 2) &allow-other-keys)
  (remf-keywords args :stream :verbosity)
  (apply #'make-instance (case verbosity
                           ((0 1) 'brief-stream-log-appender)
                           (t 'verbose-stream-log-appender))
         :stream stream
         :verbosity verbosity
         args))

(defun arnesi-logger-inspector-lookup-hook (form)
  (when (symbolp form)
    (if-bind logger (get-logger form)
      (values logger t)
      (when-bind logger-name (get form 'logger)
        (when-bind logger (get-logger logger-name)
          (values logger t))))))

(defclass file-log-appender (stream-log-appender)
  ((log-file :initarg :log-file :accessor log-file
             :documentation "Name of the file to write log messages to."))
  (:documentation "Logs to a file. the output of the file logger
  is not meant to be read directly by a human."))

(defmethod append-message ((category log-category) (appender file-log-appender)
                           message level)
  (with-output-to-file (log-file (log-file appender)
				 :if-exists :append
				 :if-does-not-exist :create)
    (format log-file "(~S ~D ~S ~S)~%" level (get-universal-time) (name category) message)))

(defun make-file-log-appender (file-name)
  (make-instance 'file-log-appender :log-file file-name))

;;;; ** Creating Loggers

(defmacro deflogger (name ancestors &key compile-time-level level appender appenders documentation)
  (declare (ignore documentation)
           (type symbol name))
  (unless (eq (symbol-package name) *package*)
    (warn "When defining a logger named ~A the home package of the symbol is not *package* (not (eq ~A ~A)) "
          (let ((*package* (find-package "KEYWORD")))
            (format nil "~S" name))
          (symbol-package name) *package*))
  (when appender
    (setf appenders (append appenders (list appender))))
  (let ((ancestors (mapcar (lambda (ancestor-name)
			     `(or (get-logger ',ancestor-name)
				  (error "Attempt to define a sub logger of the undefined logger ~S."
					 ',ancestor-name)))
			   ancestors)))
    (flet ((make-log-helper (suffix level)
	     (let ((logger-macro-name (intern (strcat name "." suffix))))
               `(progn
                 (setf (get ',logger-macro-name 'logger) ',name)
                 (defmacro ,logger-macro-name (message-control &rest message-args)
  first check at compile time
                     (if (compile-time-enabled-p (get-logger ',name) ,level)
                         ;; then check at runtime
                         `(progn
                           (when (enabled-p (load-time-value (get-logger ',',name)) ,',level)
                             ,(if message-args
                                  `(handle (load-time-value (get-logger ',',name)) (list ,message-control ,@message-args)
                                    ',',level)
                                  `(handle (load-time-value (get-logger ',',name)) ,message-control ',',level)))
                           (values))
                         (values)))))))
      `(progn
         (eval-when (:load-toplevel :execute)
           (setf (get-logger ',name) (make-instance 'log-category
                                                    :name ',name
                                                    ,@(cond (level
                                                             `(:level ,level))
                                                            ((not ancestors)
                                                             `(:level +debug+))
                                                            (t '()))
                                                    ,@(when compile-time-level
                                                        `(:compile-time-level ,compile-time-level))
                                                    :appenders (remove nil (list ,@appenders))
                                                    :ancestors (list ,@ancestors))))
	 ,(make-log-helper '#:dribble '+dribble+)
	 ,(make-log-helper '#:debug '+debug+)
	 ,(make-log-helper '#:info '+info+)
	 ,(make-log-helper '#:warn '+warn+)
	 ,(make-log-helper '#:error '+error+)
	 ,(make-log-helper '#:fatal '+fatal+)
        (values)))))



  Copyright ( c ) 2002 - 2006 ,   
;; All rights reserved. 
;; 
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;; 
;;  - Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 
;;  - Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;;
   - Neither the name of    , nor  , nor the names
;;    of its contributors may be used to endorse or promote products
;;    derived from this software without specific prior written permission.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  " AS IS " AND ANY EXPRESS OR IMPLIED WARRANTIES , INCLUDING , BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
  OWNER OR     ANY DIRECT , INDIRECT , INCIDENTAL ,
  SPECIAL , EXEMPLARY , OR CONSEQUENTIAL DAMAGES ( INCLUDING , BUT NOT
  LIMITED TO , PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ; LOSS OF USE ,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  THEORY OF LIABILITY , WHETHER IN CONTRACT , STRICT LIABILITY , OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

 -*- lisp -*-
 * A Trivial logging facility
 A logger is a way to have the system generate a text message and
 have that messaged saved somewhere for future review. Logging can
 be used as a debugging mechanism or for just reporting on the
 status of a system.
 Logs are sent to a particular log category, each log category
 sends the messages it receives to its handlers. A handler's job
 is to take a message and write it somewhere. Log categories are
 organized in a hierarchy and messages sent to a log category will
 also be sent to that category's ancestors.
 Each log category has a log level which is used to determine
 whether are particular message should be processed or
 not. Categories inherit their log level from their ancestors. If a
 category has multiple fathers its log level is the min of the
 levels of its fathers.
 ** Log Levels
 ** Log Categories
 Runtime levels
 Compile time levels
 ** Handling Messages
 turn off line wrapping for the entire time while inside the loggers
 if we have any appenders send them the message
 send the message to our ancestors	     
 what else should we do?
 *** Stream log appender
 ** Creating Loggers
 then check at runtime
 All rights reserved. 
 
 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions are
 met:
 
  - Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.
 
  - Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in the
    documentation and/or other materials provided with the distribution.

    of its contributors may be used to endorse or promote products
    derived from this software without specific prior written permission.
 
 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
 LOSS OF USE ,
 DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :it.bese.arnesi)






(eval-always
  (defconstant +dribble+ 0)
  (defconstant +debug+   1)
  (defconstant +info+    2)
  (defconstant +warn+    3)
  (defconstant +error+   4)
  (defconstant +fatal+   5)

  (defparameter *log-level-names* (coerce '(+dribble+ +debug+ +info+ +warn+ +error+ +fatal+)
                                          'simple-vector))
  (deflookup-table logger))

(defun log-level-name-of (level)
  (when (not (<= 0 level #.(1- (length *log-level-names*))))
    (error "~S is an invalid log level" level))
  (aref *log-level-names* level))


(defclass log-category ()
  ((ancestors :initform '()     :accessor ancestors :initarg :ancestors
              :documentation "The log categories this category inherits from.")
   (children  :initform '()     :accessor children  :initarg :children
              :documentation "The log categories which inherit from this category.")
   (appenders :initform '()     :accessor appenders :initarg :appenders
              :documentation "A list of appender objects this category sholud send messages to.")
   (level     :initform nil :initarg :level :accessor level
              :type (or null integer)
              :documentation "This category's log level.")
   (compile-time-level
              :initform +dribble+ :initarg :compile-time-level :accessor compile-time-level
              :type integer
              :documentation "This category's compile time log level. Any log expression below this level will macro-expand to NIL.")
   (name      :initarg :name :accessor name)))

(defmethod make-load-form ((self log-category) &optional env)
  (declare (ignore env))
  `(let ((result (get-logger ',(name self))))
     (assert result)
     result))

(defmethod print-object ((category log-category) stream)
  (print-unreadable-object (category stream :type t :identity t)
    (format stream "~S ~a"
	    (if (slot-boundp category 'name)
		(name category)
		"#<NO NAME>")
	    (level category))))

(defmethod shared-initialize :after ((l log-category) slot-names
                                     &key ancestors &allow-other-keys)
  (declare (ignore slot-names))
  (dolist (anc ancestors)
    (pushnew l (children anc) :test (lambda (a b)
				     (eql (name a) (name b))))))

(defmethod enabled-p ((cat log-category) level)
  (>= level (log.level cat)))

(defmethod log.level ((cat log-category))
  (or (level cat)
      (if (ancestors cat)
          (loop for ancestor in (ancestors cat)
                minimize (log.level ancestor))
          (error "Can't determine level for ~S" cat))))

(defmethod log.level ((cat-name symbol))
  (log.level (get-logger cat-name)))

(defmethod (setf log.level) (new-level (cat log-category)
                             &optional (recursive t))
  "Change the log level of CAT to NEW-LEVEL. If RECUSIVE is T the
  setting is also applied to the sub categories of CAT."
  (setf (slot-value cat 'level) new-level)
  (when recursive
    (dolist (child (children cat))
      (setf (log.level child) new-level)))
  new-level)

(defmethod (setf log.level) (new-level (cat-name symbol) &optional (recursive t))
  (setf (log.level (get-logger cat-name) recursive) new-level))

(defmethod (setf log.level) (new-level (cat-name null) &optional (recursive t))
  (declare (ignore new-level cat-name recursive))
  (error "NIL does not specify a category."))

(defmethod compile-time-enabled-p ((cat log-category) level)
  (>= level (log.compile-time-level cat)))

(defmethod log.compile-time-level ((cat log-category))
  (or (compile-time-level cat)
      (if (ancestors cat)
          (loop for ancestor in (ancestors cat)
                minimize (log.compile-time-level ancestor))
          (error "Can't determine compile time level for ~S" cat))))

(defmethod log.compile-time-level ((cat-name symbol))
  (log.compile-time-level (get-logger cat-name)))

(defmethod (setf log.compile-time-level) (new-level (cat log-category)
                                          &optional (recursive t))
  "Change the compile time log level of CAT to NEW-LEVEL. If RECUSIVE is T the
  setting is also applied to the sub categories of CAT."
  (setf (slot-value cat 'compile-time-level) new-level)
  (when recursive
    (dolist (child (children cat))
      (setf (log.compile-time-level child) new-level)))
  new-level)

(defmethod (setf log.compile-time-level) (new-level (cat-name symbol) &optional (recursive t))
  (setf (log.compile-time-level (get-logger cat-name) recursive) new-level))

(defmethod (setf log.compile-time-level) (new-level (cat-name null) &optional (recursive t))
  (declare (ignore new-level cat-name recursive))
  (error "NIL does not specify a category."))

(defmacro with-logger-level (logger-name new-level &body body)
  "Set the level of the listed logger(s) to NEW-LEVEL and restore the original value in an unwind-protect."
  (cond ((consp logger-name)
         `(with-logger-level ,(pop logger-name) ,new-level
           ,(if logger-name
                `(with-logger-level ,logger-name ,new-level
                  ,@body)
                `(progn
                  ,@body))))
        ((symbolp logger-name)
         (with-unique-names (logger old-level)
           `(let* ((,logger (get-logger ',logger-name))
                   (,old-level (level ,logger)))
             (setf (level ,logger) ,new-level)
             (unwind-protect
                  (progn ,@body)
               (setf (level ,logger) ,old-level)))))
        (t (error "Don't know how to interpret ~S as a logger name" logger-name))))


(defmacro with-logging-io (&body body)
  `(let ((*print-right-margin* most-positive-fixnum)
         (*print-readably* nil)
         (*print-length* 64)
         (*package* #+ecl (find-package "COMMON-LISP")
                    #-ecl #.(find-package "COMMON-LISP")))
    ,@body))

(defgeneric handle (category message level)
  (:documentation "Message is either a string or a list. When it's a list and the first element is a string then it's processed as args to cl:format."))

(defmethod handle :around ((cat log-category) message level)
  (with-logging-io
    (call-next-method)))

(defmethod handle ((cat log-category) message level)
  (labels ((do-appenders (ac)
	     (awhen (appenders ac)
	       (dolist (appender it)
		 (append-message cat appender message level)))

	     (mapc #'do-appenders (ancestors ac))))
    (do-appenders cat)))

(defgeneric append-message (category log-appender message level)
  (:method :around (category log-appender message level)
    (ignore-errors
      (call-next-method))))


(defclass appender ()
  ((verbosity :initform 2 :initarg :verbosity :accessor verbosity-of)))
  
(defclass stream-log-appender (appender)
  ((stream :initarg :stream :accessor log-stream))
  (:documentation "Human readable to the console logger."))

(defmethod make-instance ((class (eql (find-class 'stream-log-appender)))
                          &rest initargs)
  (declare (ignore initargs))
  (error "STREAM-LOG-APPENDER is an abstract class. You must use either brief-stream-log-appender or verbose-stream-log-appender objects."))

(defmethod append-message :around (category (appender stream-log-appender) (message cons) level)
  (append-message category appender (apply #'format nil message) level))

(defclass brief-stream-log-appender (stream-log-appender)
  ((last-message-year :initform 0)
   (last-message-month :initform 0)
   (last-message-day :initform 0))
  (:documentation "A subclass of stream-log-appender with minimal
  'overhead' text in log messages. This amounts to: not printing
  the package names of log categories and log levels and a more
  compact printing of the current time."))

(defclass verbose-stream-log-appender (stream-log-appender)
  ()
  (:documentation "A subclass of stream-log-appender which
  attempts to be as precise as possible, category names and log
  level names are printed with a package prefix and the time is
  printed in long format."))

(defmethod append-message :around ((category log-category) (s stream-log-appender)
                                   message level)
  (restart-case
      (call-next-method)
    (use-*debug-io* ()
      :report "Use the current value of *debug-io*"
      (setf (log-stream s) *debug-io*)
      (append-message category s message level))
    (use-*standard-output* ()
      :report "Use the current value of *standard-output*"
      (setf (log-stream s) *standard-output*)
      (append-message category s message level))
    (silence-logger ()
      :report "Ignore all future messages to this logger."
      (setf (log-stream s) (make-broadcast-stream)))))

(eval-always
  (defparameter *max-category-name-length* 12))

(defmethod append-message ((category log-category) (s brief-stream-log-appender)
                           message level)
  (multiple-value-bind (second minute hour day month year)
      (decode-universal-time (get-universal-time))
    (declare (ignore second))
    (with-slots (last-message-year last-message-month last-message-day)
        s
      (unless (and (= year last-message-year)
                   (= month last-message-month)
                   (= day last-message-day))
        (format (log-stream s) "--TIME MARK ~4,'0D-~2,'0D-~2,'0D--~%"
                year month day)
        (setf last-message-year year
              last-message-month month
              last-message-day day)))
    (let* ((category-name (symbol-name (name category)))
           (level-name (symbol-name level))
           (category-length (length category-name)))
      (format (log-stream s)
              #.(strcat "~2,'0D:~2,'0D ~"
                        *max-category-name-length*
                        "@A ~7A ")
              hour minute
              (subseq category-name
                      (max 0 (- category-length
                                *max-category-name-length*))
                      category-length)
              (subseq level-name 1 (1- (length level-name)))))
    (format (log-stream s) "~A~%" message)))

(defmethod append-message ((category log-category) (s verbose-stream-log-appender)
                            message level)
  (multiple-value-bind (second minute hour date month year)
      (decode-universal-time (get-universal-time))
    (format (log-stream s)
            "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D.~2,'0D ~A/~A: "
            year month date hour minute second
            (name category) level)
    (format (log-stream s) "~A~%" message)))

(defun make-stream-log-appender (&rest args &key (stream *debug-io*) (verbosity 2) &allow-other-keys)
  (remf-keywords args :stream :verbosity)
  (apply #'make-instance (case verbosity
                           ((0 1) 'brief-stream-log-appender)
                           (t 'verbose-stream-log-appender))
         :stream stream
         :verbosity verbosity
         args))

(defun arnesi-logger-inspector-lookup-hook (form)
  (when (symbolp form)
    (if-bind logger (get-logger form)
      (values logger t)
      (when-bind logger-name (get form 'logger)
        (when-bind logger (get-logger logger-name)
          (values logger t))))))

(defclass file-log-appender (stream-log-appender)
  ((log-file :initarg :log-file :accessor log-file
             :documentation "Name of the file to write log messages to."))
  (:documentation "Logs to a file. the output of the file logger
  is not meant to be read directly by a human."))

(defmethod append-message ((category log-category) (appender file-log-appender)
                           message level)
  (with-output-to-file (log-file (log-file appender)
				 :if-exists :append
				 :if-does-not-exist :create)
    (format log-file "(~S ~D ~S ~S)~%" level (get-universal-time) (name category) message)))

(defun make-file-log-appender (file-name)
  (make-instance 'file-log-appender :log-file file-name))


(defmacro deflogger (name ancestors &key compile-time-level level appender appenders documentation)
  (declare (ignore documentation)
           (type symbol name))
  (unless (eq (symbol-package name) *package*)
    (warn "When defining a logger named ~A the home package of the symbol is not *package* (not (eq ~A ~A)) "
          (let ((*package* (find-package "KEYWORD")))
            (format nil "~S" name))
          (symbol-package name) *package*))
  (when appender
    (setf appenders (append appenders (list appender))))
  (let ((ancestors (mapcar (lambda (ancestor-name)
			     `(or (get-logger ',ancestor-name)
				  (error "Attempt to define a sub logger of the undefined logger ~S."
					 ',ancestor-name)))
			   ancestors)))
    (flet ((make-log-helper (suffix level)
	     (let ((logger-macro-name (intern (strcat name "." suffix))))
               `(progn
                 (setf (get ',logger-macro-name 'logger) ',name)
                 (defmacro ,logger-macro-name (message-control &rest message-args)
  first check at compile time
                     (if (compile-time-enabled-p (get-logger ',name) ,level)
                         `(progn
                           (when (enabled-p (load-time-value (get-logger ',',name)) ,',level)
                             ,(if message-args
                                  `(handle (load-time-value (get-logger ',',name)) (list ,message-control ,@message-args)
                                    ',',level)
                                  `(handle (load-time-value (get-logger ',',name)) ,message-control ',',level)))
                           (values))
                         (values)))))))
      `(progn
         (eval-when (:load-toplevel :execute)
           (setf (get-logger ',name) (make-instance 'log-category
                                                    :name ',name
                                                    ,@(cond (level
                                                             `(:level ,level))
                                                            ((not ancestors)
                                                             `(:level +debug+))
                                                            (t '()))
                                                    ,@(when compile-time-level
                                                        `(:compile-time-level ,compile-time-level))
                                                    :appenders (remove nil (list ,@appenders))
                                                    :ancestors (list ,@ancestors))))
	 ,(make-log-helper '#:dribble '+dribble+)
	 ,(make-log-helper '#:debug '+debug+)
	 ,(make-log-helper '#:info '+info+)
	 ,(make-log-helper '#:warn '+warn+)
	 ,(make-log-helper '#:error '+error+)
	 ,(make-log-helper '#:fatal '+fatal+)
        (values)))))



  Copyright ( c ) 2002 - 2006 ,   
   - Neither the name of    , nor  , nor the names
  " AS IS " AND ANY EXPRESS OR IMPLIED WARRANTIES , INCLUDING , BUT NOT
  OWNER OR     ANY DIRECT , INDIRECT , INCIDENTAL ,
  SPECIAL , EXEMPLARY , OR CONSEQUENTIAL DAMAGES ( INCLUDING , BUT NOT
  THEORY OF LIABILITY , WHETHER IN CONTRACT , STRICT LIABILITY , OR TORT
