235 lines
6.3 KiB
Scheme
235 lines
6.3 KiB
Scheme
|
; Copyright (c) 1993-2000 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
;; Options for openlog
|
||
|
|
|
||
|
|
(define-enumerated-type syslog-option :syslog-option
|
||
|
|
syslog-option?
|
||
|
|
the-syslog-options
|
||
|
|
syslog-option-name
|
||
|
|
syslog-option-index
|
||
|
|
;; The order of these is known to the C code.
|
||
|
|
(console
|
||
|
|
delay
|
||
|
|
no-delay
|
||
|
|
log-pid))
|
||
|
|
|
||
|
|
(define-exported-binding "syslog-options" the-syslog-options)
|
||
|
|
|
||
|
|
(define-enum-set-type syslog-options :syslog-options
|
||
|
|
syslog-options?
|
||
|
|
make-syslog-options
|
||
|
|
|
||
|
|
syslog-option
|
||
|
|
syslog-option?
|
||
|
|
the-syslog-options
|
||
|
|
syslog-option-index)
|
||
|
|
|
||
|
|
(define-exported-binding "syslog-options?" syslog-options?)
|
||
|
|
|
||
|
|
(define default-syslog-options (syslog-options))
|
||
|
|
|
||
|
|
(define-enumerated-type syslog-facility :syslog-facility
|
||
|
|
syslog-facility?
|
||
|
|
syslog-facilities
|
||
|
|
syslog-facility-name
|
||
|
|
syslog-facility-index
|
||
|
|
;; Options for openlog
|
||
|
|
;; The order of these is known to the C code.
|
||
|
|
(authorization
|
||
|
|
cron
|
||
|
|
daemon
|
||
|
|
kernel
|
||
|
|
lpr
|
||
|
|
mail
|
||
|
|
news
|
||
|
|
user
|
||
|
|
uucp
|
||
|
|
local0 local1 local2 local3 local4 local5 local6 local7))
|
||
|
|
|
||
|
|
(define default-syslog-facility (syslog-facility user))
|
||
|
|
|
||
|
|
(define-exported-binding "syslog-facility-type" :syslog-facility)
|
||
|
|
(define-exported-binding "syslog-facilities" syslog-facilities)
|
||
|
|
|
||
|
|
(define-enumerated-type syslog-level :syslog-level
|
||
|
|
syslog-level?
|
||
|
|
syslog-levels
|
||
|
|
syslog-level-name
|
||
|
|
syslog-level-index
|
||
|
|
;; The order of these is known to the C code.
|
||
|
|
(emergency
|
||
|
|
alert
|
||
|
|
critical
|
||
|
|
error
|
||
|
|
warning
|
||
|
|
notice
|
||
|
|
info
|
||
|
|
debug))
|
||
|
|
|
||
|
|
(define-exported-binding "syslog-level-type" :syslog-level)
|
||
|
|
(define-exported-binding "syslog-levels" syslog-levels)
|
||
|
|
|
||
|
|
(define-enum-set-type syslog-mask :syslog-mask
|
||
|
|
syslog-mask?
|
||
|
|
make-syslog-mask
|
||
|
|
|
||
|
|
syslog-level
|
||
|
|
syslog-level?
|
||
|
|
syslog-levels
|
||
|
|
syslog-level-index)
|
||
|
|
|
||
|
|
(define-exported-binding "syslog-mask?" syslog-mask?)
|
||
|
|
(define-exported-binding ":syslog-mask" :syslog-mask)
|
||
|
|
|
||
|
|
(define (syslog-mask-upto level)
|
||
|
|
(let loop ((index (syslog-level-index level)) (levels '()))
|
||
|
|
(if (< index 0)
|
||
|
|
(make-syslog-mask levels)
|
||
|
|
(loop (- index 1)
|
||
|
|
(cons (vector-ref syslog-levels index)
|
||
|
|
levels)))))
|
||
|
|
|
||
|
|
(define syslog-mask-all (make-syslog-mask (vector->list syslog-levels)))
|
||
|
|
|
||
|
|
(define default-syslog-mask syslog-mask-all)
|
||
|
|
|
||
|
|
(import-lambda-definition openlog (ident options facility)
|
||
|
|
"sch_openlog")
|
||
|
|
(import-lambda-definition unix-syslog (level opt-facility message)
|
||
|
|
"sch_syslog")
|
||
|
|
(import-lambda-definition setlogmask! (logmask)
|
||
|
|
"sch_setlogmask")
|
||
|
|
(import-lambda-definition closelog ()
|
||
|
|
"sch_closelog")
|
||
|
|
|
||
|
|
(define-record-type syslog-channel :syslog-channel
|
||
|
|
(make-syslog-channel ident options facility mask)
|
||
|
|
syslog-channel?
|
||
|
|
(ident syslog-channel-ident)
|
||
|
|
(options syslog-channel-options)
|
||
|
|
(facility syslog-channel-facility)
|
||
|
|
(mask syslog-channel-mask))
|
||
|
|
|
||
|
|
(define (syslog-channel-equivalent? channel-1 channel-2)
|
||
|
|
(and (string=? (syslog-channel-ident channel-1)
|
||
|
|
(syslog-channel-ident channel-2))
|
||
|
|
(enum-set=? (syslog-channel-options channel-1)
|
||
|
|
(syslog-channel-options channel-2))
|
||
|
|
;; facility can be specified with each syslog-write
|
||
|
|
(enum-set=? (syslog-channel-mask channel-1)
|
||
|
|
(syslog-channel-mask channel-2))))
|
||
|
|
|
||
|
|
(define current-syslog-channel 'unitinialized)
|
||
|
|
(define current-syslog-channel-lock 'unitinialized)
|
||
|
|
|
||
|
|
(define (initialize-syslog)
|
||
|
|
(set! current-syslog-channel #f)
|
||
|
|
(set! current-syslog-channel-lock (make-lock)))
|
||
|
|
|
||
|
|
(define open-syslog-channel make-syslog-channel)
|
||
|
|
|
||
|
|
(define (close-syslog-channel channel)
|
||
|
|
(obtain-lock current-syslog-channel-lock)
|
||
|
|
(if (syslog-channel-equivalent? channel
|
||
|
|
current-syslog-channel)
|
||
|
|
(closelog))
|
||
|
|
(release-lock current-syslog-channel-lock))
|
||
|
|
|
||
|
|
(define (with-syslog-channel channel thunk)
|
||
|
|
(dynamic-wind
|
||
|
|
(lambda ()
|
||
|
|
(obtain-lock current-syslog-channel-lock))
|
||
|
|
(lambda ()
|
||
|
|
(if (or (not current-syslog-channel)
|
||
|
|
(not (syslog-channel-equivalent? channel
|
||
|
|
current-syslog-channel)))
|
||
|
|
(begin
|
||
|
|
(if current-syslog-channel
|
||
|
|
(closelog))
|
||
|
|
(openlog (syslog-channel-ident channel)
|
||
|
|
(syslog-channel-options channel)
|
||
|
|
(syslog-channel-facility channel))
|
||
|
|
(if (not (enum-set=? (syslog-channel-mask channel)
|
||
|
|
default-syslog-mask))
|
||
|
|
(setlogmask! (syslog-channel-mask channel)))
|
||
|
|
(set! current-syslog-channel channel)))
|
||
|
|
(thunk))
|
||
|
|
(lambda ()
|
||
|
|
(release-lock current-syslog-channel-lock))))
|
||
|
|
|
||
|
|
(define (syslog-write level message channel)
|
||
|
|
(with-syslog-channel
|
||
|
|
channel
|
||
|
|
(lambda ()
|
||
|
|
(unix-syslog level (syslog-channel-facility channel) message))))
|
||
|
|
|
||
|
|
(define (change-syslog-channel channel ident options facility mask)
|
||
|
|
(make-syslog-channel (or ident
|
||
|
|
(syslog-channel-ident channel))
|
||
|
|
(or options
|
||
|
|
(syslog-channel-options channel))
|
||
|
|
(or facility
|
||
|
|
(syslog-channel-facility channel))
|
||
|
|
(or mask
|
||
|
|
(syslog-channel-mask channel))))
|
||
|
|
|
||
|
|
(define dynamic-syslog-channel
|
||
|
|
(make-preserved-thread-fluid
|
||
|
|
(make-syslog-channel "scsh"
|
||
|
|
default-syslog-options
|
||
|
|
default-syslog-facility
|
||
|
|
default-syslog-mask)))
|
||
|
|
|
||
|
|
(define (syslog level message . rest)
|
||
|
|
(syslog-write level message
|
||
|
|
(cond
|
||
|
|
((null? rest)
|
||
|
|
(thread-fluid dynamic-syslog-channel))
|
||
|
|
((and (null? (cdr rest))
|
||
|
|
(syslog-channel? (car rest)))
|
||
|
|
(car rest))
|
||
|
|
(else
|
||
|
|
;; this might be a little excessive allocation
|
||
|
|
(apply change-syslog-channel
|
||
|
|
(thread-fluid dynamic-syslog-channel)
|
||
|
|
(append rest '(#f)))))))
|
||
|
|
|
||
|
|
(define (with-syslog-destination ident options facility mask thunk)
|
||
|
|
(let-thread-fluid dynamic-syslog-channel
|
||
|
|
(change-syslog-channel
|
||
|
|
(thread-fluid dynamic-syslog-channel)
|
||
|
|
ident options facility mask)
|
||
|
|
thunk))
|
||
|
|
|
||
|
|
(define (set-syslog-channel! channel)
|
||
|
|
(set-thread-fluid! dynamic-syslog-channel
|
||
|
|
channel))
|
||
|
|
|
||
|
|
(define (set-syslog-destination! ident options facility mask)
|
||
|
|
(set-thread-fluid! dynamic-syslog-channel
|
||
|
|
(change-syslog-channel
|
||
|
|
(thread-fluid dynamic-syslog-channel)
|
||
|
|
ident options facility mask)))
|
||
|
|
|
||
|
|
;----------------
|
||
|
|
; A record type whose only purpose is to run some code when we start up an
|
||
|
|
; image.
|
||
|
|
|
||
|
|
(define-record-type reinitializer :reinitializer
|
||
|
|
(make-reinitializer thunk)
|
||
|
|
reinitializer?
|
||
|
|
(thunk reinitializer-thunk))
|
||
|
|
|
||
|
|
(define-record-discloser :reinitializer
|
||
|
|
(lambda (r)
|
||
|
|
(list 'reinitializer (reinitializer-thunk r))))
|
||
|
|
|
||
|
|
(define-record-resumer :reinitializer
|
||
|
|
(lambda (r)
|
||
|
|
((reinitializer-thunk r))))
|
||
|
|
|
||
|
|
(initialize-syslog)
|
||
|
|
|
||
|
|
(define syslog-reinitializer
|
||
|
|
(make-reinitializer initialize-syslog))
|