First stab at proper syslog interface.
This commit is contained in:
sperber
parent
b42bc454e3
commit
e2a6e37c70
|
|
@ -128,12 +128,15 @@ SCSHOBJS = \
|
||||||
scsh/select.o scsh/select1.o \
|
scsh/select.o scsh/select1.o \
|
||||||
scsh/sleep1.o \
|
scsh/sleep1.o \
|
||||||
scsh/syscalls.o scsh/syscalls1.o \
|
scsh/syscalls.o scsh/syscalls1.o \
|
||||||
|
scsh/syslog1.o \
|
||||||
scsh/time.o scsh/time1.o \
|
scsh/time.o scsh/time1.o \
|
||||||
scsh/tty.o scsh/tty1.o \
|
scsh/tty.o scsh/tty1.o \
|
||||||
scsh/userinfo1.o \
|
scsh/userinfo1.o \
|
||||||
scsh/sighandlers1.o \
|
scsh/sighandlers1.o \
|
||||||
scsh/regexp/libregex.a
|
scsh/regexp/libregex.a
|
||||||
|
|
||||||
|
SCSH_INITIALIZERS = s48_init_syslog
|
||||||
|
|
||||||
UNIX_OBJS = c/unix/misc.o c/unix/io.o c/unix/fd-io.o c/unix/event.o
|
UNIX_OBJS = c/unix/misc.o c/unix/io.o c/unix/fd-io.o c/unix/event.o
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -168,6 +171,7 @@ EXTERNAL_OBJECTS = $(SOCKET_OBJECTS) $(LOOKUP_OBJECTS)
|
||||||
EXTERNAL_FLAGS = $(SOCKET_FLAGS)
|
EXTERNAL_FLAGS = $(SOCKET_FLAGS)
|
||||||
EXTERNAL_INITIALIZERS = $(ADDITIONAL_INITIALIZER) $(SOCKET_INITIALIZERS) \
|
EXTERNAL_INITIALIZERS = $(ADDITIONAL_INITIALIZER) $(SOCKET_INITIALIZERS) \
|
||||||
$(LOOKUP_INITIALIZERS) \
|
$(LOOKUP_INITIALIZERS) \
|
||||||
|
$(SCSH_INITIALIZERS) \
|
||||||
s48_init_cig $(CIGGEDINIT) s48_init_userinfo s48_init_sighandlers \
|
s48_init_cig $(CIGGEDINIT) s48_init_userinfo s48_init_sighandlers \
|
||||||
s48_init_re_low
|
s48_init_re_low
|
||||||
|
|
||||||
|
|
@ -239,7 +243,7 @@ scsh/syscalls.o: scsh/syscalls1.h scsh/dirstuff1.h scsh/fdports1.h \
|
||||||
|
|
||||||
scsh/sighandlers1.o: scsh/sighandlers1.h
|
scsh/sighandlers1.o: scsh/sighandlers1.h
|
||||||
|
|
||||||
|
scsh/syslog1.o: c/scheme48.h
|
||||||
|
|
||||||
include $(srcdir)/scsh/machine/Makefile.inc
|
include $(srcdir)/scsh/machine/Makefile.inc
|
||||||
# Berkeley make wants to see this instead: (or use GNU make on BSD. -bri)
|
# Berkeley make wants to see this instead: (or use GNU make on BSD. -bri)
|
||||||
|
|
|
||||||
|
|
@ -1077,34 +1077,27 @@
|
||||||
(with-lock :syntax)))
|
(with-lock :syntax)))
|
||||||
|
|
||||||
(define-interface syslog-interface
|
(define-interface syslog-interface
|
||||||
(export openlog
|
(export (syslog-option :syntax)
|
||||||
syslog
|
make-syslog-options
|
||||||
syslog-w/id
|
syslog-options?
|
||||||
closelog
|
(syslog-options :syntax)
|
||||||
syslog-option/default
|
syslog-options-on?
|
||||||
syslog-option/console-on-error
|
|
||||||
syslog-option/open-now
|
(syslog-facility :syntax)
|
||||||
syslog-option/include-pid
|
syslog-facility?
|
||||||
syslog-facility/authorisation
|
|
||||||
syslog-facility/daemon
|
(syslog-level :syntax)
|
||||||
syslog-facility/kernel
|
syslog-level?
|
||||||
syslog-facility/local0
|
|
||||||
syslog-facility/local1
|
levels->syslog-mask
|
||||||
syslog-facility/local2
|
(syslog-mask :syntax)
|
||||||
syslog-facility/local3
|
syslog-mask-all
|
||||||
syslog-facility/local4
|
syslog-mask-upto
|
||||||
syslog-facility/local5
|
syslog-mask-levels-on?
|
||||||
syslog-facility/local6
|
|
||||||
syslog-facility/local7
|
open-syslog-channel
|
||||||
syslog-facility/lpr
|
close-syslog-channel
|
||||||
syslog-facility/mail
|
syslog-write
|
||||||
syslog-facility/user
|
|
||||||
syslog-level/default
|
with-syslog-destination
|
||||||
syslog-level/emergency
|
syslog))
|
||||||
syslog-level/alert
|
|
||||||
syslog-level/critical
|
|
||||||
syslog-level/error
|
|
||||||
syslog-level/warning
|
|
||||||
syslog-level/notice
|
|
||||||
syslog-level/info
|
|
||||||
syslog-level/debug))
|
|
||||||
|
|
|
||||||
|
|
@ -167,6 +167,9 @@
|
||||||
scsh-version
|
scsh-version
|
||||||
tty-flags
|
tty-flags
|
||||||
scsh-internal-tty-flags ; Not exported
|
scsh-internal-tty-flags ; Not exported
|
||||||
|
|
||||||
|
syslog
|
||||||
|
|
||||||
let-opt ; optional-arg parsing & defaulting
|
let-opt ; optional-arg parsing & defaulting
|
||||||
|
|
||||||
architecture ; Was this by JMG ??
|
architecture ; Was this by JMG ??
|
||||||
|
|
@ -450,3 +453,10 @@
|
||||||
handle
|
handle
|
||||||
threads) ; sleep
|
threads) ; sleep
|
||||||
(files dot-locking))
|
(files dot-locking))
|
||||||
|
|
||||||
|
(define-structure syslog syslog-interface
|
||||||
|
(open scheme define-record-types finite-types
|
||||||
|
locks thread-fluids
|
||||||
|
external-calls
|
||||||
|
bitwise)
|
||||||
|
(files syslog))
|
||||||
|
|
|
||||||
|
|
@ -887,7 +887,4 @@ void s48_init_syscalls(void)
|
||||||
S48_EXPORT_FUNCTION(scm_gethostname);
|
S48_EXPORT_FUNCTION(scm_gethostname);
|
||||||
S48_EXPORT_FUNCTION(df_errno_msg);
|
S48_EXPORT_FUNCTION(df_errno_msg);
|
||||||
S48_EXPORT_FUNCTION(scm_crypt);
|
S48_EXPORT_FUNCTION(scm_crypt);
|
||||||
S48_EXPORT_FUNCTION(scm_openlog);
|
|
||||||
S48_EXPORT_FUNCTION(scm_syslog);
|
|
||||||
S48_EXPORT_FUNCTION(scm_closelog);
|
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -944,74 +944,3 @@
|
||||||
(error "illegal char in salt " salt))
|
(error "illegal char in salt " salt))
|
||||||
(if (> (string-length key) 8) (error "key too long " (string-length key)))
|
(if (> (string-length key) 8) (error "key too long " (string-length key)))
|
||||||
(%crypt key salt)))
|
(%crypt key salt)))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;;;
|
|
||||||
;;; Interface to syslog
|
|
||||||
;;;
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
|
|
||||||
(define-enum-constants-from-zero syslog-option
|
|
||||||
(default
|
|
||||||
cons
|
|
||||||
ndelay
|
|
||||||
pid))
|
|
||||||
|
|
||||||
(define-enum-constants-from-zero syslog-facility
|
|
||||||
(default
|
|
||||||
auth
|
|
||||||
daemon
|
|
||||||
kern
|
|
||||||
local0
|
|
||||||
local1
|
|
||||||
local2
|
|
||||||
local3
|
|
||||||
local4
|
|
||||||
local5
|
|
||||||
local6
|
|
||||||
local7
|
|
||||||
lpr
|
|
||||||
mail
|
|
||||||
user))
|
|
||||||
|
|
||||||
;;; sorted by priority
|
|
||||||
(define-enum-constants-from-zero syslog-level
|
|
||||||
(default
|
|
||||||
emerg
|
|
||||||
alert
|
|
||||||
crit
|
|
||||||
err
|
|
||||||
warning
|
|
||||||
notice
|
|
||||||
info
|
|
||||||
debug))
|
|
||||||
|
|
||||||
(define-stubless-foreign %openlog (ident option facility) "scm_openlog")
|
|
||||||
(define-stubless-foreign %syslog (facility level message) "scm_syslog")
|
|
||||||
(define-stubless-foreign closelog () "scm_closelog")
|
|
||||||
|
|
||||||
(define (openlog ident . args)
|
|
||||||
(let-optionals args ((option syslog-option/default)
|
|
||||||
(facility syslog-facility/default))
|
|
||||||
(%openlog ident option facility)))
|
|
||||||
|
|
||||||
(define (syslog message . args)
|
|
||||||
(let-optionals args ((level syslog-level/default)
|
|
||||||
(facility syslog-facility/default))
|
|
||||||
(%syslog facility level (double-char #\% message))))
|
|
||||||
|
|
||||||
|
|
||||||
(define (double-char the-char s)
|
|
||||||
(let* ((ans-len (string-fold (lambda (c sum)
|
|
||||||
(+ sum (if (char=? c the-char) 2 1)))
|
|
||||||
0 s))
|
|
||||||
(ans (make-string ans-len)))
|
|
||||||
(string-fold (lambda (c i)
|
|
||||||
(let ((i (if (char=? c the-char)
|
|
||||||
(begin (string-set! ans i the-char) (+ i 1))
|
|
||||||
i)))
|
|
||||||
(string-set! ans i c)
|
|
||||||
(+ i 1)))
|
|
||||||
0 s)
|
|
||||||
ans))
|
|
||||||
|
|
@ -0,0 +1,227 @@
|
||||||
|
; 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)
|
||||||
|
(standard-error #o10)
|
||||||
|
(log-pid #o20)))
|
||||||
|
|
||||||
|
(define-record-type syslog-options :syslog-options
|
||||||
|
(really-make-syslog-options value)
|
||||||
|
syslog-options?
|
||||||
|
(value syslog-options-value))
|
||||||
|
|
||||||
|
(define (syslog-options=? options-1 options-2)
|
||||||
|
(= (syslog-options-value options-1)
|
||||||
|
(syslog-options-value options-2)))
|
||||||
|
|
||||||
|
(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 '()))
|
||||||
|
|
||||||
|
; 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 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-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-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 #f)
|
||||||
|
(define 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
|
||||||
|
;; 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
|
||||||
|
(make-syslog-channel ident options facility mask)
|
||||||
|
thunk))
|
||||||
|
|
@ -0,0 +1,326 @@
|
||||||
|
/* Copyright (c) 1993-2000 by Richard Kelsey and Jonathan Rees.
|
||||||
|
See file COPYING. */
|
||||||
|
|
||||||
|
#include <syslog.h>
|
||||||
|
#include "scheme48.h"
|
||||||
|
|
||||||
|
static s48_value sch_openlog(s48_value sch_ident,
|
||||||
|
s48_value sch_option,
|
||||||
|
s48_value sch_facility),
|
||||||
|
sch_setlogmask(s48_value sch_logmask),
|
||||||
|
sch_syslog(s48_value sch_level,
|
||||||
|
s48_value sch_facility,
|
||||||
|
s48_value sch_message),
|
||||||
|
sch_closelog(void);
|
||||||
|
|
||||||
|
/*
|
||||||
|
* Record types imported from Scheme.
|
||||||
|
*/
|
||||||
|
static s48_value syslog_options_type_binding = S48_FALSE;
|
||||||
|
static s48_value syslog_facility_type_binding = S48_FALSE;
|
||||||
|
static s48_value syslog_facilities_binding = S48_FALSE;
|
||||||
|
static s48_value syslog_level_type_binding = S48_FALSE;
|
||||||
|
static s48_value syslog_levels_binding = S48_FALSE;
|
||||||
|
static s48_value syslog_mask_type_binding = S48_FALSE;
|
||||||
|
|
||||||
|
/*
|
||||||
|
* Install all exported functions in Scheme 48.
|
||||||
|
*/
|
||||||
|
void
|
||||||
|
s48_init_syslog(void)
|
||||||
|
{
|
||||||
|
S48_EXPORT_FUNCTION(sch_openlog);
|
||||||
|
S48_EXPORT_FUNCTION(sch_syslog);
|
||||||
|
S48_EXPORT_FUNCTION(sch_setlogmask);
|
||||||
|
S48_EXPORT_FUNCTION(sch_closelog);
|
||||||
|
|
||||||
|
S48_GC_PROTECT_GLOBAL(syslog_options_type_binding);
|
||||||
|
syslog_options_type_binding =
|
||||||
|
s48_get_imported_binding("syslog-options-type");
|
||||||
|
|
||||||
|
S48_GC_PROTECT_GLOBAL(syslog_facility_type_binding);
|
||||||
|
syslog_facility_type_binding =
|
||||||
|
s48_get_imported_binding("syslog-facility-type");
|
||||||
|
S48_GC_PROTECT_GLOBAL(syslog_facilities_binding);
|
||||||
|
syslog_facilities_binding =
|
||||||
|
s48_get_imported_binding("syslog-facilities");
|
||||||
|
|
||||||
|
S48_GC_PROTECT_GLOBAL(syslog_level_type_binding);
|
||||||
|
syslog_level_type_binding =
|
||||||
|
s48_get_imported_binding("syslog-level-type");
|
||||||
|
S48_GC_PROTECT_GLOBAL(syslog_levels_binding);
|
||||||
|
syslog_levels_binding =
|
||||||
|
s48_get_imported_binding("syslog-levels");
|
||||||
|
|
||||||
|
S48_GC_PROTECT_GLOBAL(syslog_mask_type_binding);
|
||||||
|
syslog_mask_type_binding =
|
||||||
|
s48_get_imported_binding("syslog-mask-type");
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ************************************************************ */
|
||||||
|
/* Syslog options.
|
||||||
|
*
|
||||||
|
* We translate the local bits into our own bits and vice versa.
|
||||||
|
*/
|
||||||
|
|
||||||
|
static s48_value
|
||||||
|
s48_enter_syslog_options(int syslog_options)
|
||||||
|
{
|
||||||
|
s48_value sch_syslog_options;
|
||||||
|
int my_syslog_options;
|
||||||
|
|
||||||
|
my_syslog_options =
|
||||||
|
(LOG_CONS & syslog_options ? 00001 : 0) |
|
||||||
|
(LOG_ODELAY & syslog_options ? 00002 : 0) |
|
||||||
|
(LOG_NDELAY & syslog_options ? 00004 : 0) |
|
||||||
|
(LOG_PERROR & syslog_options ? 00010 : 0) |
|
||||||
|
(LOG_PID & syslog_options ? 00020 : 0);
|
||||||
|
|
||||||
|
sch_syslog_options = s48_make_record(syslog_options_type_binding);
|
||||||
|
S48_UNSAFE_RECORD_SET(sch_syslog_options, 0, s48_enter_fixnum(my_syslog_options));
|
||||||
|
|
||||||
|
return sch_syslog_options;
|
||||||
|
}
|
||||||
|
|
||||||
|
static int
|
||||||
|
s48_extract_syslog_options(s48_value sch_syslog_options)
|
||||||
|
{
|
||||||
|
int c_syslog_options;
|
||||||
|
int syslog_options;
|
||||||
|
|
||||||
|
s48_check_record_type(sch_syslog_options, syslog_options_type_binding);
|
||||||
|
|
||||||
|
syslog_options =
|
||||||
|
s48_extract_fixnum(S48_UNSAFE_RECORD_REF(sch_syslog_options, 0));
|
||||||
|
|
||||||
|
c_syslog_options =
|
||||||
|
(00001 & syslog_options ? LOG_CONS : 0) |
|
||||||
|
(00002 & syslog_options ? LOG_ODELAY : 0) |
|
||||||
|
(00004 & syslog_options ? LOG_NDELAY : 0) |
|
||||||
|
(00010 & syslog_options ? LOG_PERROR : 0) |
|
||||||
|
(00020 & syslog_options ? LOG_PID : 0);
|
||||||
|
|
||||||
|
return c_syslog_options;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ************************************************************ */
|
||||||
|
/* Syslog facility.
|
||||||
|
*
|
||||||
|
* We translate the local facility into our own encoding and vice versa.
|
||||||
|
*/
|
||||||
|
|
||||||
|
/* The order of these is known to the Scheme code. */
|
||||||
|
static int syslog_facilities[] = {
|
||||||
|
LOG_AUTH,
|
||||||
|
LOG_CRON,
|
||||||
|
LOG_DAEMON,
|
||||||
|
LOG_KERN,
|
||||||
|
LOG_LPR,
|
||||||
|
LOG_MAIL,
|
||||||
|
LOG_NEWS,
|
||||||
|
LOG_USER,
|
||||||
|
LOG_UUCP,
|
||||||
|
LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3,
|
||||||
|
LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7
|
||||||
|
};
|
||||||
|
|
||||||
|
|
||||||
|
static s48_value
|
||||||
|
s48_enter_syslog_facility(int syslog_facility)
|
||||||
|
{
|
||||||
|
s48_value sch_syslog_facility;
|
||||||
|
int my_syslog_facility;
|
||||||
|
|
||||||
|
for (my_syslog_facility = 0;
|
||||||
|
my_syslog_facility < (sizeof(syslog_facilities) / sizeof(int));
|
||||||
|
++my_syslog_facility) {
|
||||||
|
if (syslog_facility == my_syslog_facility)
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
|
||||||
|
sch_syslog_facility =
|
||||||
|
S48_VECTOR_REF(S48_SHARED_BINDING_REF(syslog_facilities_binding),
|
||||||
|
my_syslog_facility);
|
||||||
|
|
||||||
|
return sch_syslog_facility;
|
||||||
|
}
|
||||||
|
|
||||||
|
static s48_value
|
||||||
|
s48_extract_syslog_facility(s48_value sch_syslog_facility)
|
||||||
|
{
|
||||||
|
int c_syslog_facility;
|
||||||
|
int syslog_facility;
|
||||||
|
|
||||||
|
s48_check_record_type(sch_syslog_facility, syslog_facility_type_binding);
|
||||||
|
|
||||||
|
syslog_facility =
|
||||||
|
s48_extract_fixnum(S48_UNSAFE_RECORD_REF(sch_syslog_facility, 1));
|
||||||
|
|
||||||
|
c_syslog_facility = syslog_facilities[syslog_facility];
|
||||||
|
|
||||||
|
return c_syslog_facility;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ************************************************************ */
|
||||||
|
/* Syslog level.
|
||||||
|
*
|
||||||
|
* We translate the local level into our own encoding and vice versa.
|
||||||
|
*/
|
||||||
|
|
||||||
|
/* The order of these is known to the Scheme code. */
|
||||||
|
static int syslog_levels[] = {
|
||||||
|
LOG_EMERG,
|
||||||
|
LOG_ALERT,
|
||||||
|
LOG_CRIT,
|
||||||
|
LOG_ERR,
|
||||||
|
LOG_LPR,
|
||||||
|
LOG_WARNING,
|
||||||
|
LOG_NOTICE,
|
||||||
|
LOG_INFO,
|
||||||
|
LOG_DEBUG
|
||||||
|
};
|
||||||
|
|
||||||
|
|
||||||
|
static s48_value
|
||||||
|
s48_enter_syslog_level(int syslog_level)
|
||||||
|
{
|
||||||
|
s48_value sch_syslog_level;
|
||||||
|
int my_syslog_level;
|
||||||
|
|
||||||
|
for (my_syslog_level = 0;
|
||||||
|
my_syslog_level < (sizeof(syslog_levels) / sizeof(int));
|
||||||
|
++my_syslog_level) {
|
||||||
|
if (syslog_level == my_syslog_level)
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
|
||||||
|
sch_syslog_level =
|
||||||
|
S48_VECTOR_REF(S48_SHARED_BINDING_REF(syslog_levels_binding),
|
||||||
|
my_syslog_level);
|
||||||
|
|
||||||
|
return sch_syslog_level;
|
||||||
|
}
|
||||||
|
|
||||||
|
static s48_value
|
||||||
|
s48_extract_syslog_level(s48_value sch_syslog_level)
|
||||||
|
{
|
||||||
|
int c_syslog_level;
|
||||||
|
int syslog_level;
|
||||||
|
|
||||||
|
s48_check_record_type(sch_syslog_level, syslog_level_type_binding);
|
||||||
|
|
||||||
|
syslog_level =
|
||||||
|
s48_extract_fixnum(S48_UNSAFE_RECORD_REF(sch_syslog_level, 1));
|
||||||
|
|
||||||
|
c_syslog_level = syslog_levels[syslog_level];
|
||||||
|
|
||||||
|
return c_syslog_level;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ************************************************************ */
|
||||||
|
/* Syslog mask.
|
||||||
|
*
|
||||||
|
* We translate the local bits into our own bits and vice versa.
|
||||||
|
*/
|
||||||
|
|
||||||
|
static s48_value
|
||||||
|
s48_enter_syslog_mask(int syslog_mask)
|
||||||
|
{
|
||||||
|
s48_value sch_syslog_mask;
|
||||||
|
int my_syslog_mask;
|
||||||
|
|
||||||
|
my_syslog_mask =
|
||||||
|
(LOG_MASK(LOG_EMERG) & syslog_mask ? 00001 : 0) |
|
||||||
|
(LOG_MASK(LOG_ALERT) & syslog_mask ? 00002 : 0) |
|
||||||
|
(LOG_MASK(LOG_CRIT) & syslog_mask ? 00004 : 0) |
|
||||||
|
(LOG_MASK(LOG_ERR) & syslog_mask ? 00010 : 0) |
|
||||||
|
(LOG_MASK(LOG_WARNING) & syslog_mask ? 00020 : 0) |
|
||||||
|
(LOG_MASK(LOG_NOTICE) & syslog_mask ? 00040 : 0) |
|
||||||
|
(LOG_MASK(LOG_INFO) & syslog_mask ? 00100 : 0) |
|
||||||
|
(LOG_MASK(LOG_DEBUG) & syslog_mask ? 00200 : 0);
|
||||||
|
|
||||||
|
sch_syslog_mask = s48_make_record(syslog_mask_type_binding);
|
||||||
|
S48_UNSAFE_RECORD_SET(sch_syslog_mask, 0, s48_enter_fixnum(my_syslog_mask));
|
||||||
|
|
||||||
|
return sch_syslog_mask;
|
||||||
|
}
|
||||||
|
|
||||||
|
static int
|
||||||
|
s48_extract_syslog_mask(s48_value sch_syslog_mask)
|
||||||
|
{
|
||||||
|
int c_syslog_mask;
|
||||||
|
int syslog_mask;
|
||||||
|
|
||||||
|
s48_check_record_type(sch_syslog_mask, syslog_mask_type_binding);
|
||||||
|
|
||||||
|
syslog_mask =
|
||||||
|
s48_extract_fixnum(S48_UNSAFE_RECORD_REF(sch_syslog_mask, 0));
|
||||||
|
|
||||||
|
c_syslog_mask =
|
||||||
|
(00001 & syslog_mask ? LOG_MASK(LOG_EMERG) : 0) |
|
||||||
|
(00002 & syslog_mask ? LOG_MASK(LOG_ALERT) : 0) |
|
||||||
|
(00004 & syslog_mask ? LOG_MASK(LOG_CRIT) : 0) |
|
||||||
|
(00010 & syslog_mask ? LOG_MASK(LOG_ERR) : 0) |
|
||||||
|
(00010 & syslog_mask ? LOG_MASK(LOG_WARNING) : 0) |
|
||||||
|
(00010 & syslog_mask ? LOG_MASK(LOG_NOTICE) : 0) |
|
||||||
|
(00010 & syslog_mask ? LOG_MASK(LOG_INFO) : 0) |
|
||||||
|
(00020 & syslog_mask ? LOG_MASK(LOG_DEBUG) : 0);
|
||||||
|
|
||||||
|
return c_syslog_mask;
|
||||||
|
}
|
||||||
|
|
||||||
|
/*
|
||||||
|
* Interface to openlog, setlogmask, syslog, and closelog.
|
||||||
|
* ### Must still prevent cores.
|
||||||
|
*/
|
||||||
|
|
||||||
|
static int syslog_open = 0;
|
||||||
|
|
||||||
|
static s48_value
|
||||||
|
sch_openlog(s48_value sch_ident,
|
||||||
|
s48_value sch_options,
|
||||||
|
s48_value sch_facility)
|
||||||
|
{
|
||||||
|
if (syslog_open)
|
||||||
|
s48_raise_string_os_error("syslog is already open");
|
||||||
|
openlog(s48_extract_string(sch_ident),
|
||||||
|
s48_extract_syslog_options(sch_options),
|
||||||
|
s48_extract_syslog_facility(sch_facility));
|
||||||
|
syslog_open = 1;
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
static s48_value
|
||||||
|
sch_setlogmask(s48_value sch_logmask)
|
||||||
|
{
|
||||||
|
int logmask = s48_extract_syslog_mask(sch_logmask);
|
||||||
|
int previous_logmask = setlogmask(logmask);
|
||||||
|
|
||||||
|
return s48_enter_syslog_mask(previous_logmask);
|
||||||
|
}
|
||||||
|
|
||||||
|
static s48_value
|
||||||
|
sch_syslog(s48_value sch_level, s48_value sch_opt_facility,
|
||||||
|
s48_value sch_message)
|
||||||
|
{
|
||||||
|
int facility =
|
||||||
|
S48_EQ_P(S48_FALSE, sch_opt_facility)
|
||||||
|
? 0 : s48_extract_syslog_facility(sch_opt_facility);
|
||||||
|
int level = s48_extract_syslog_level(sch_level);
|
||||||
|
|
||||||
|
if (!syslog_open)
|
||||||
|
s48_raise_string_os_error("syslog isn't open");
|
||||||
|
syslog(facility | level, s48_extract_string (sch_message));
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
static s48_value
|
||||||
|
sch_closelog(void)
|
||||||
|
{
|
||||||
|
|
||||||
|
if (!syslog_open)
|
||||||
|
s48_raise_string_os_error("syslog isn't open");
|
||||||
|
closelog();
|
||||||
|
syslog_open = 0;
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
Loading…
Reference in New Issue