crow-httpd: switch from CVS RCSID to GIT revision for versioning
[mmondor.git] / mmsoftware / cl / server / syslog.lisp
CommitLineData
1b9e8dcd 1;;;; $Id: syslog.lisp,v 1.5 2013/04/14 02:31:43 mmondor Exp $
afc38233
MM
2
3#|
4
5Copyright (c) 2012, Matthew Mondor
6All rights reserved.
7
8Redistribution and use in source and binary forms, with or without
9modification, are permitted provided that the following conditions
10are met:
111. Redistributions of source code must retain the above copyright
12 notice, this list of conditions and the following disclaimer.
132. Redistributions in binary form must reproduce the above copyright
14 notice, this list of conditions and the following disclaimer in the
15 documentation and/or other materials provided with the distribution.
16
17THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR
18IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
19OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
20IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT,
21INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
22BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
23USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
24THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
26THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27
28|#
29
30;;;; Simple ECL interface to the unix syslog(3) facility.
31;;;;
32;;;; NetBSD supports various thread-safe *_r() functions but Linux/glibc
33;;;; hasn't yet copied them. What we do is wrap the traditional portable
34;;;; interface with a lock for thread-safety.
35;;;; Ideally, some *FEATURES* specific compilation conditionals should
36;;;; be used to use the more efficient BSD interface where available.
37
38(declaim (optimize (speed 3) (safety 1) (debug 3)))
39
4abc3114
MM
40(eval-when (:compile-toplevel #-:mm-ecl-standalone :load-toplevel)
41 (load "character"))
42
afc38233
MM
43(defpackage :syslog
44 (:use :cl)
45 (:export #:openlog
46 #:closelog
47 #:syslog
48 #:with-syslog-constants))
49
50(in-package :syslog)
51
afc38233
MM
52
53
54;;; FFI helpers (borrowed from my earlier ecl-unix.lisp, should ideally
55;;; be in a library)
56
57(defmacro define-c-constants (header-name c-header-name &rest constants)
58 (check-type header-name keyword)
59 `(let ()
60 (ffi:clines ,(format nil "#include <~A>" c-header-name))
61 ,@(mapcar #'(lambda (c)
62 (let ((s (intern (string (first c)))))
63 `(progn
64 (defconstant ,s
65 (ffi:c-inline () () :fixnum ,(second c)
66 :one-liner t
67 :side-effects nil))
68 (declaim (type fixnum ,s))
69 (export ',s))))
70 constants)))
71
72
73;;; Syslog related constants
74
75;;; XXX Has to be tested on Linux in case it doesn't support all of these.
76;;; We could possibly make them use CPP conditionals transparently...
77(define-c-constants :syslog "syslog.h"
78 (+log-emerg+ "LOG_EMERG")
79 (+log-alert+ "LOG_ALERT")
80 (+log-crit+ "LOG_CRIT")
81 (+log-err+ "LOG_ERR")
82 (+log-warning+ "LOG_WARNING")
83 (+log-notice+ "LOG_NOTICE")
84 (+log-info+ "LOG_INFO")
85 (+log-debug+ "LOG_DEBUG")
86 (+log-cons+ "LOG_CONS")
87 (+log-ndelay+ "LOG_NDELAY")
88 (+log-perror+ "LOG_PERROR")
89 (+log-pid+ "LOG_PID")
90 (+log-auth+ "LOG_AUTH")
91 (+log-authpriv+ "LOG_AUTHPRIV")
92 (+log-cron+ "LOG_CRON")
93 (+log-daemon+ "LOG_DAEMON")
94 (+log-ftp+ "LOG_FTP")
95 (+log-kern+ "LOG_KERN")
96 (+log-lpr+ "LOG_LPR")
97 (+log-mail+ "LOG_MAIL")
98 (+log-news+ "LOG_NEWS")
99 (+log-syslog+ "LOG_SYSLOG")
100 (+log-user+ "LOG_USER")
101 (+log-uucp+ "LOG_UUCP")
102 (+log-local0+ "LOG_LOCAL0")
103 (+log-local1+ "LOG_LOCAL1")
104 (+log-local2+ "LOG_LOCAL2")
105 (+log-local3+ "LOG_LOCAL3")
106 (+log-local4+ "LOG_LOCAL4")
107 (+log-local5+ "LOG_LOCAL5")
108 (+log-local6+ "LOG_LOCAL6")
109 (+log-local7+ "LOG_LOCAL7"))
110
111
112;;; Control
113
114(defvar *syslog-open* nil)
4abc3114 115(defvar *syslog-lock* (mp:make-lock :name 'syslog-lock :recursive t))
1b9e8dcd
MM
116;;; Syslog doesn't copy ident
117(ffi:clines "
118#include <stdlib.h>
119#include <string.h>
120char *syslog_ident = NULL;")
afc38233
MM
121
122
123;;; Interface
124
125(defun openlog (ident logopt facility)
126 (mp:with-lock (*syslog-lock*)
127 (unless *syslog-open*
128 (ffi:c-inline (ident logopt facility) (:cstring :int :int) :void
129 "
130if (syslog_ident != NULL) {
131 free(syslog_ident);
132 syslog_ident = NULL;
133}
134syslog_ident = strdup(#0);
135openlog(syslog_ident, #1, #2);
136" :one-liner nil)
137 (setf *syslog-open* t)))
138 (values))
139
140(defun closelog ()
141 (mp:with-lock (*syslog-lock*)
142 (when *syslog-open*
143 (ffi:c-inline () () :void "closelog()" :one-liner t)
144 (setf *syslog-open* nil)))
145 (values))
146
147(defun syslog (priority fmt &rest fmt-args)
1e777252 148 ;; Substitute any \0 by <U+00>, append \0 and encode string to UTF-8
cd912c5a
MM
149 (let* ((msg (if fmt-args
150 (apply #'format nil fmt fmt-args)
151 fmt))
4abc3114
MM
152 (fixed (with-output-to-string (out)
153 (with-input-from-string (in msg)
154 (loop
155 for c = (handler-case
156 (read-char in)
157 (end-of-file ()
158 nil))
159 while c
160 do
161 (if (char= #\Nul c)
162 (write-string "<U+00>" out)
1e777252
MM
163 (write-char c out))
164 finally
165 (write-char #\Nul out)))))
4abc3114
MM
166 (emsg (character:utf-8-string-encode fixed))
167 (foreign (si:make-foreign-data-from-array emsg)))
afc38233 168 (mp:with-lock (*syslog-lock*)
4abc3114
MM
169 (ffi:c-inline (priority foreign)
170 (:int :object) :void
171 "syslog(#0, \"%s\", (char *)((#1)->foreign.data))"
172 :one-liner t))
173 (si:free-foreign-data foreign))
174 (values))