/[log4cl]/log4cl/logger.lisp
ViewVC logotype

Contents of /log4cl/logger.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Fri Mar 5 15:09:34 2004 UTC (10 years, 1 month ago) by nlamirault
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +20 -7 lines
some modifications
1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2
3 ;;;; *************************************************************************
4 ;;;; FILE IDENTIFICATION
5 ;;;;
6 ;;;; Name: logger.lisp
7 ;;;; Purpose: Main logger
8 ;;;; Developer: Nicolas Lamirault <lam@tuxfamily.org>
9 ;;;;
10 ;;;; This file, part of log4cl, is Copyright (c) 2003 by Nicolas Lamirault
11 ;;;;
12 ;;;; log4cl users are granted the rights to distribute and use this software
13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
15 ;;;;
16 ;;;; $Id
17 ;;;;
18 ;;;; *************************************************************************
19
20
21 (in-package #:log4cl)
22
23
24 (defparameter *levels* '(:debug :info :warning :error :fatal))
25
26
27 (defclass logger ()
28 ((name :initform "logger"
29 :initarg :name
30 :accessor logger-name)
31 (appenders :initform '()
32 :reader logger-appenders)
33 (level :initarg :level
34 :initform :info
35 :reader logger-level)
36 (possible-levels :initform *levels*
37 :reader logger-possible-levels)
38 (current-appender :initarg :current-appender
39 :initform nil
40 :accessor logger-current-appender)
41 (parent :reader logger-parent))
42 (:documentation "Logger"))
43
44
45
46 ;; (defmethod initialize-instance :after ((logger logger) &rest initargs)
47 ;; (declare (ignore initargs))
48 ;; (with-slots (appenders) logger
49 ;; (push (make-instance 'console-appender :name "default")
50 ;; (slot-value logger 'appenders))))
51
52
53
54 (defmacro with-logger ((logger &key name appenders level) &body body)
55 `(let ((,logger (make-instance 'logger
56 :name ,name
57 :appenders ,appenders
58 :level ,level)))
59 ,@body))
60
61
62
63 ;; -------
64 ;; Levels
65 ;; -------
66
67
68 (defmacro with-level (logger level &body body)
69 `(when (not (null (level-rank ,logger ,level)))
70 ,@body))
71
72
73 (defmacro with-not-level (logger level &body body)
74 `(when (null (level-rank ,logger ,level))
75 ,@body))
76
77
78 (defmethod level-rank ((logger logger) level)
79 "Get the rank level"
80 (position level (logger-possible-levels logger) :test #'string-equal))
81
82
83 (defmethod set-level ((logger logger) new-level)
84 "Change the logger's level"
85 (with-level logger new-level
86 (setf (slot-value logger 'level) new-level)))
87
88
89 (defmethod is-enabled-for ((logger logger) level)
90 "Verify is priority can be treate"
91 (with-level logger level
92 (<= (level-rank logger (logger-level logger)) (level-rank logger level))))
93
94
95 (defmethod add-level ((logger logger) new-level &key place level)
96 "Add a new level. We can set the new-level with the least importance if place
97 keyword is 'least', or the most importance with 'most', or after a level with
98 'relative' keyword"
99 (with-not-level logger new-level
100 (let* ((levels (logger-possible-levels logger))
101 (new-levels (if (not (null place))
102 (cond ((string-equal place "least")
103 (append (list new-level) levels))
104 ((string-equal place "most")
105 (append levels (list new-level)))
106 ((string-equal place "relative")
107 (with-level logger level
108 (let ((rank (level-rank logger level)))
109 (append (subseq levels 0 rank)
110 (list new-level)
111 (subseq levels rank (length levels)))))))
112 levels)))
113 (setf (slot-value logger 'possible-levels) new-levels))))
114
115
116 (defmethod remove-level ((logger logger) level)
117 "Remove a level from list's levels"
118 (setf (slot-value logger 'possible-levels)
119 (remove level (logger-possible-levels logger) :test #'string=)))
120
121
122
123 ;; ---------------------
124 ;; Appenders operations
125 ;; ---------------------
126
127
128 (defmethod get-appender ((logger logger) type)
129 "Look for the appender type"
130 (find type (logger-appenders logger) :test #'string-equal :key #'type-of))
131
132
133 (defmethod is-appender ((logger logger) appender)
134 "Is the appender is attached to this category"
135 (member appender (logger-appenders logger) :test #'string-equal :key #'appender-name))
136
137
138 (defmethod add-appender ((logger logger) appender)
139 "Add an appender to the logger"
140 (setf (slot-value logger 'appenders) (cons appender (logger-appenders logger)))
141 (when (null (logger-current-appender logger))
142 (setf (slot-value logger 'current-appender) (appender-name appender))))
143
144
145 (defmethod remove-appender ((logger logger) appender)
146 "Remove an appender"
147 (with-slots (appenders current-appender) logger
148 (setf appenders (remove (appender-name appender) (logger-appenders logger)
149 :test #'string-equal :key #'appender-name))
150 (when (string-equal (logger-current-appender logger) (appender-name appender))
151 (setf current-appender (car (logger-appenders logger))))))
152
153
154 (defmacro with-appender ((appender) logger appender-type &body body)
155 `(let ((,appender (get-appender ,logger ,appender-type)))
156 (when (not (null appender))
157 ,@body)))
158
159
160
161 ;; --------------
162 ;; Log functions
163 ;; --------------
164
165
166 (defmethod log-debug ((logger logger) message &key appender-type)
167 "Log message with debug level"
168 (log-message logger :error message :appender-type appender-type))
169
170
171 (defmethod log-info ((logger logger) message &key appender-type)
172 "Log message with info level"
173 (log-message logger :info message :appender-type appender-type))
174
175
176 (defmethod log-warning ((logger logger) message &key appender-type)
177 "Log message with warning level"
178 (log-message logger :warning message :appender-type appender-type))
179
180
181 (defmethod log-error ((logger logger) message &key appender-type)
182 "Log message with error level"
183 (log-message logger :error message :appender-type appender-type))
184
185
186 (defmethod log-fatal ((logger logger) message &key appender-type)
187 "Log message with fatal level"
188 (log-message logger :fatal message :appender-type appender-type))
189
190
191 (defmethod log-message ((logger logger) level message &key appender-type)
192 "Log message with the appropriate level if the default level of the logger is less important
193 If appender type is specified, we log only with it, with all appenders"
194 (let ((name (logger-name logger))
195 (level-name (symbol-name level)))
196 (when (is-enabled-for logger level)
197 (if (not (null appender-type))
198 (with-appender (appender) logger (symbol-name appender-type)
199 (log-msg appender name level-name message))
200 (mapc #'(lambda (app)
201 (log-msg app name level-name message))
202 (logger-appenders logger))))))
203
204
205
206 ;; -----------------------------------
207 ;; Predicat to know the current level
208 ;; -----------------------------------
209
210
211 (defmethod levelp ((logger logger) level)
212 "Predicat for level"
213 (not (null (member level (logger-possible-levels logger)))))
214
215
216 (defmethod debugp ((logger logger))
217 "Return TRUE if logger's level is debug"
218 (equal (logger-level logger) :debug))
219
220
221 (defmethod infop ((logger logger))
222 "Return TRUE if logger's level is info"
223 (equal (logger-level logger) :info))
224
225
226 (defmethod warningp ((logger logger))
227 "Return TRUE if logger's level is warning"
228 (equal (logger-level logger) :warning))
229
230
231 (defmethod errorp ((logger logger))
232 "Return TRUE if logger's level is error"
233 (equal (logger-level logger) :error))
234
235
236 (defmethod fatalp ((logger logger))
237 "Return TRUE if logger's level is fatal"
238 (equal (logger-level logger) :fatal))
239
240
241
242
243
244
245

  ViewVC Help
Powered by ViewVC 1.1.5