286 lines
7.9 KiB
Scheme
286 lines
7.9 KiB
Scheme
; Copyright (c) 1993-2000 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
;; Options for openlog
|
|
|
|
(define-finite-type syslog-option :syslog-option
|
|
(mask)
|
|
syslog-option?
|
|
the-syslog-options
|
|
syslog-option-name
|
|
syslog-option-index
|
|
(mask syslog-option-mask)
|
|
;; These values are known to the C code.
|
|
((console #o01)
|
|
(delay #o02)
|
|
(no-delay #o04)
|
|
(log-pid #o10)))
|
|
|
|
(define-record-type syslog-options :syslog-options
|
|
(really-make-syslog-options value)
|
|
syslog-options?
|
|
(value syslog-options-value))
|
|
|
|
(define syslog-options=? eq?)
|
|
|
|
(define-exported-binding "syslog-options-type" :syslog-options)
|
|
|
|
(define (syslog-options-on? options0 options1)
|
|
(= 0 (bitwise-and (syslog-options-value options1)
|
|
(bitwise-not (syslog-options-value options0)))))
|
|
|
|
(define (make-syslog-options options)
|
|
(really-make-syslog-options
|
|
(apply bitwise-ior (map syslog-option-mask options))))
|
|
|
|
(define default-syslog-options (make-syslog-options '()))
|
|
|
|
(define (make-mask-record->list get-value get-mask record-vector)
|
|
(lambda (mask-record)
|
|
(let ((value (get-value mask-record))
|
|
(n-syslog-options (vector-length record-vector)))
|
|
(let loop ((i 0) (list '()))
|
|
(cond
|
|
((>= i n-syslog-options)
|
|
list)
|
|
((zero? (bitwise-and value
|
|
(get-mask (vector-ref record-vector i))))
|
|
(loop (+ 1 i) list))
|
|
(else
|
|
(loop (+ 1 i) (cons (vector-ref record-vector i)
|
|
list))))))))
|
|
|
|
(define syslog-options->list
|
|
(make-mask-record->list syslog-options-value
|
|
syslog-option-mask
|
|
the-syslog-options))
|
|
|
|
; Simplifying syntax, e.g. (syslog-options delay console)
|
|
|
|
(define-syntax syslog-options
|
|
(syntax-rules ()
|
|
((syslog-options name ...)
|
|
(make-syslog-options (list (syslog-option name) ...)))))
|
|
|
|
(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 syslog-facility=? eq?)
|
|
|
|
(define default-syslog-facility (syslog-facility user))
|
|
|
|
(define-exported-binding "syslog-facility-type" :syslog-facility)
|
|
(define-exported-binding "syslog-facilities" syslog-facilities)
|
|
|
|
(define-finite-type syslog-level :syslog-level
|
|
(mask)
|
|
syslog-level?
|
|
syslog-levels
|
|
syslog-level-name
|
|
syslog-level-index
|
|
(mask syslog-level-mask)
|
|
;; Options for syslog
|
|
;; The order and the values of these is known to the C code.
|
|
((emergency #o001)
|
|
(alert #o002)
|
|
(critical #o004)
|
|
(error #o010)
|
|
(warning #o020)
|
|
(notice #o040)
|
|
(info #o100)
|
|
(debug #o200)))
|
|
|
|
(define syslog-level=? eq?)
|
|
|
|
(define-exported-binding "syslog-level-type" :syslog-level)
|
|
(define-exported-binding "syslog-levels" syslog-levels)
|
|
|
|
(define-record-type syslog-mask :syslog-mask
|
|
(make-syslog-mask value)
|
|
syslog-mask?
|
|
(value syslog-mask-value))
|
|
|
|
(define (syslog-mask=? mask-1 mask-2)
|
|
(= (syslog-mask-value mask-1)
|
|
(syslog-mask-value mask-2)))
|
|
|
|
(define-exported-binding "syslog-mask-type" :syslog-mask)
|
|
|
|
(define (syslog-mask-levels-on? mask-1 mask-2)
|
|
(= 0 (bitwise-and (syslog-mask-value mask-2)
|
|
(bitwise-not (syslog-mask-value mask-1)))))
|
|
|
|
(define (levels->syslog-mask levels)
|
|
(make-syslog-mask
|
|
(apply bitwise-ior
|
|
(map syslog-level-mask levels))))
|
|
|
|
(define syslog-mask->levels
|
|
(make-mask-record->list syslog-mask-value
|
|
syslog-level-mask
|
|
syslog-levels))
|
|
|
|
(define-syntax syslog-mask
|
|
(syntax-rules ()
|
|
((syslog-mask name ...)
|
|
(levels->syslog-mask (list (syslog-level name) ...)))))
|
|
|
|
(define (syslog-mask-upto level)
|
|
(let loop ((index (syslog-level-index level)) (levels '()))
|
|
(if (< index 0)
|
|
(levels->syslog-mask levels)
|
|
(loop (- index 1) (cons index levels)))))
|
|
|
|
(define syslog-mask-all (levels->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))
|
|
(syslog-options=? (syslog-channel-options channel-1)
|
|
(syslog-channel-options channel-2))
|
|
;; facility can be specified with each syslog-write
|
|
(syslog-mask=? (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))
|
|
|
|
;; THUNK must not escape
|
|
(define (with-syslog-channel channel thunk)
|
|
(obtain-lock current-syslog-channel-lock)
|
|
(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 (syslog-mask=? (syslog-channel-mask channel)
|
|
default-syslog-mask))
|
|
(setlogmask! (syslog-channel-mask channel)))
|
|
(set! current-syslog-channel channel)))
|
|
(thunk)
|
|
(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 (list-ref-carefully list n default)
|
|
(cond
|
|
((null? list) default)
|
|
((zero? n) (car list))
|
|
(else
|
|
(list-ref-carefully (cdr list) (- n 1) default))))
|
|
|
|
(define (change-syslog-channel channel . rest)
|
|
(let ((ident (list-ref-carefully rest 0 #f))
|
|
(options (list-ref-carefully rest 1 #f))
|
|
(facility (list-ref-carefully rest 2 #f))
|
|
(mask (list-ref-carefully rest 3 #f)))
|
|
(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-thread-fluid
|
|
(make-syslog-channel "scheme48"
|
|
default-syslog-options
|
|
default-syslog-facility
|
|
default-syslog-mask)))
|
|
|
|
(define (syslog level message . rest)
|
|
(syslog-write level message
|
|
(if (and (not (null? rest))
|
|
(null? (cdr rest))
|
|
(syslog-channel? (car rest)))
|
|
(car rest)
|
|
;; this might be a little excessive allocation
|
|
(apply change-syslog-channel
|
|
(thread-fluid dynamic-syslog-channel)
|
|
rest))))
|
|
|
|
(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))
|
|
|
|
;----------------
|
|
; 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))
|