204 lines
8 KiB
Common Lisp
204 lines
8 KiB
Common Lisp
(defpackage :vom
|
|
;; DON'T use :cl, otherwise most of the implementations bitch about using
|
|
;; error and warn functions
|
|
(:use)
|
|
;; import everything from cl that we actually need. while obnoxious, it makes
|
|
;; sure vom runs smoothly on most (all?) implementations.
|
|
(:import-from #:cl
|
|
#:t #:nil
|
|
#:defpackage #:in-package #:*package* #:package-name #:find-package
|
|
#:eval-when
|
|
#:eval
|
|
#:lambda #:defun #:multiple-value-list #:defmacro
|
|
#:return-from
|
|
#:defvar #:defparameter
|
|
#:declare #:optimize #:type #:ignore
|
|
#:keyword #:integer
|
|
#:assert
|
|
#:member
|
|
#:macro-function
|
|
#:documentation
|
|
#:let #:let* #:progn #:multiple-value-bind
|
|
#:&rest #:&key
|
|
#:if #:when #:unless #:cond
|
|
#:loop #:dolist
|
|
#:car #:cdr #:cddr
|
|
#:write-sequence #:format
|
|
#:get-universal-time
|
|
#:get-decoded-time
|
|
#:string #:string-downcase #:make-string #:concatenate
|
|
#:symbolp
|
|
#:intern
|
|
#:setf #:getf
|
|
#:max #:min
|
|
#:eq
|
|
#:+ #:- #:> #:< #:<= #:>=
|
|
#:apply #:funcall
|
|
#:append #:list #:length
|
|
#:make-synonym-stream)
|
|
(:shadow #:error
|
|
#:warn
|
|
#:debug)
|
|
(:export #:config
|
|
#:*log-stream*
|
|
#:*log-hook*
|
|
#:*config*
|
|
#:*time-formatter*
|
|
#:*log-formatter*
|
|
|
|
#:emerg
|
|
#:alert
|
|
#:crit
|
|
#:error
|
|
#:warn
|
|
#:notice
|
|
#:info
|
|
#:debug
|
|
#:debug1
|
|
#:debug2
|
|
#:debug3
|
|
#:debug4))
|
|
(in-package :vom)
|
|
|
|
;; define our *levels* and *max-level-name-length* before the define-level macro
|
|
;; is defined (so it can access them)
|
|
(eval-when (:load-toplevel :compile-toplevel)
|
|
(defparameter *levels* '(:off 0)
|
|
"Holds the log level mappings (keyword -> value).")
|
|
|
|
(defparameter *max-level-name-length* 0
|
|
"Holds the number of characters in the longest log-level name."))
|
|
|
|
(defvar *config* '(t :warn)
|
|
"Holds the logging config as a plist. Holds package -> level mappings, using
|
|
T as the default (used if logging from a package that hasn't been
|
|
configured).")
|
|
|
|
(defvar *log-stream* (make-synonym-stream 'cl:*standard-output*)
|
|
"Holds the default stream we're logging to.")
|
|
|
|
(defvar *log-hook*
|
|
(lambda (log-level package-keyword package-log-level)
|
|
(declare (ignore log-level package-keyword package-log-level))
|
|
*log-stream*)
|
|
"Holds a function that, given a log-level, a package name, and the effective
|
|
log-level for that package, returns one or more (via (values ...)) streams
|
|
that this log will be sent to.")
|
|
|
|
(defvar *package-level-cache* nil
|
|
"A cache that holds package alias -> package loglevel values for quick lookup.")
|
|
|
|
(defparameter *time-formatter*
|
|
(lambda ()
|
|
(multiple-value-bind (second minute hour)
|
|
(get-decoded-time)
|
|
(format nil "~2,'0D:~2,'0D:~2,'0D" hour minute second)))
|
|
"A function of 0 args that returns the current time in the desired format.")
|
|
|
|
(defparameter *log-formatter*
|
|
(lambda (format-str level-str package-keyword args)
|
|
(let* ((format-str (concatenate 'string "~a<~a> [~a] ~a - " format-str "~%")))
|
|
(apply 'format
|
|
(append (list
|
|
nil
|
|
format-str)
|
|
(list
|
|
(make-string (- *max-level-name-length* (length level-str))
|
|
:initial-element #\space)
|
|
level-str
|
|
(funcall *time-formatter*)
|
|
(string-downcase (string package-keyword)))
|
|
args))))
|
|
"A function that takes a format string (user-supplied), a level string (eg
|
|
'notice' or 'error'), a keyword of the current package, and a list of args
|
|
the user supplied with the format string and returns a string of the log line
|
|
we want logged.")
|
|
|
|
(defun config (package-keyword level-name)
|
|
"Configure the log level for a package (or use t for the package name to set
|
|
the default log level). The log level is given as a keyword."
|
|
(assert (member level-name *levels*))
|
|
(clear-level-cache)
|
|
(cond ((eq package-keyword t)
|
|
(setf (getf *config* t) level-name))
|
|
((symbolp package-keyword)
|
|
(let* ((name (find-package package-keyword))
|
|
(package-name (string (if name
|
|
(package-name name)
|
|
package-keyword))))
|
|
(setf (getf *config* (intern package-name :keyword)) level-name)))))
|
|
|
|
(defun find-package-level (package-keyword)
|
|
"Given package keyword (doesn't have to be an exact match, can be an alias),
|
|
find the configured loglevel of that package.
|
|
|
|
This caches the package->level connection in *package-level-cache*."
|
|
(declare (optimize (cl:speed 3) (cl:safety 0) (cl:debug 0))
|
|
(type keyword package-keyword))
|
|
(let ((cached (getf *package-level-cache* package-keyword)))
|
|
(when cached (return-from find-package-level cached))
|
|
(let* ((package (find-package package-keyword))
|
|
(package-name (when package
|
|
(intern (package-name package) :keyword)))
|
|
(package-level (getf *config* package-name))
|
|
(package-level (if package-level
|
|
package-level
|
|
(getf *config* t)))
|
|
(package-level-value (getf *levels* package-level 0)))
|
|
(setf (getf *package-level-cache* package-keyword) package-level-value)
|
|
package-level-value)))
|
|
|
|
(defun clear-level-cache ()
|
|
"Clears the package loglevel cache."
|
|
(setf *package-level-cache* nil))
|
|
|
|
(defun do-log (level-name log-level package-keyword format-str &rest args)
|
|
"The given data to the current *log-stream* stream."
|
|
(declare (optimize (cl:speed 3) (cl:safety 0) (cl:debug 0))
|
|
(type keyword level-name package-keyword)
|
|
(type integer log-level)
|
|
(type string format-str)
|
|
(type list args))
|
|
(let* ((package-level-value (find-package-level package-keyword)))
|
|
(when (<= log-level package-level-value)
|
|
(let* ((level-str (string level-name))
|
|
(logline (funcall *log-formatter* format-str level-str package-keyword args))
|
|
(log-streams (multiple-value-list
|
|
(funcall *log-hook*
|
|
log-level
|
|
package-keyword
|
|
package-level-value))))
|
|
(dolist (stream log-streams)
|
|
(write-sequence logline (if (eq stream t)
|
|
cl:*standard-output*
|
|
stream))
|
|
(cl:finish-output stream))))))
|
|
|
|
(defmacro define-level (name level-value)
|
|
"Define a log level."
|
|
(let ((macro-name (intern (format nil "LOG-~a" (string name))))
|
|
(log-sym (intern (string name))))
|
|
`(progn
|
|
(setf (getf *levels* ,name) ,level-value)
|
|
(defmacro ,macro-name (format-str &rest args)
|
|
,(format nil "Log output to the ~s log level (~a)" name level-value)
|
|
(let ((pkg (intern (package-name *package*) :keyword)))
|
|
`(do-log ,,name ,,level-value ,pkg ,format-str ,@args)))
|
|
(setf (documentation ',log-sym 'cl:function) (documentation ',macro-name 'cl:function))
|
|
(setf (macro-function ',log-sym) (macro-function ',macro-name))
|
|
(setf *max-level-name-length* (max *max-level-name-length*
|
|
(length (string ,name)))))))
|
|
|
|
(define-level :emerg 1)
|
|
(define-level :alert 2)
|
|
(define-level :crit 3)
|
|
(define-level :error 4)
|
|
(define-level :warn 5)
|
|
(define-level :notice 6)
|
|
(define-level :info 7)
|
|
(define-level :debug 8)
|
|
(define-level :debug1 9)
|
|
(define-level :debug2 10)
|
|
(define-level :debug3 11)
|
|
(define-level :debug4 12)
|
|
|