Update of /cvsroot/scsh/scsh-0.6/scsh
In directory usw-pr-cvs1:/tmp/cvs-serv3348/scsh
Modified Files:
scsh-interfaces.scm scsh-package.scm syscalls.c syscalls.scm
Added Files:
syslog.scm syslog1.c
Log Message:
First stab at proper syslog interface.
--- NEW FILE ---
; 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))
--- NEW FILE ---
/* 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;
}
Index: scsh-interfaces.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/scsh-interfaces.scm,v
retrieving revision 1.16
retrieving revision 1.17
diff -C2 -r1.16 -r1.17
*** scsh-interfaces.scm 2001/04/09 07:56:58 1.16
--- scsh-interfaces.scm 2001/06/01 16:22:26 1.17
***************
*** 1078,1110 ****
(define-interface syslog-interface
! (export openlog
! syslog
! syslog-w/id
! closelog
! syslog-option/default
! syslog-option/console-on-error
! syslog-option/open-now
! syslog-option/include-pid
! syslog-facility/authorisation
! syslog-facility/daemon
! syslog-facility/kernel
! syslog-facility/local0
! syslog-facility/local1
! syslog-facility/local2
! syslog-facility/local3
! syslog-facility/local4
! syslog-facility/local5
! syslog-facility/local6
! syslog-facility/local7
! syslog-facility/lpr
! syslog-facility/mail
! syslog-facility/user
! syslog-level/default
! syslog-level/emergency
! syslog-level/alert
! syslog-level/critical
! syslog-level/error
! syslog-level/warning
! syslog-level/notice
! syslog-level/info
! syslog-level/debug))
\ No newline at end of file
--- 1078,1103 ----
(define-interface syslog-interface
! (export (syslog-option :syntax)
! make-syslog-options
! syslog-options?
! (syslog-options :syntax)
! syslog-options-on?
!
! (syslog-facility :syntax)
! syslog-facility?
!
! (syslog-level :syntax)
! syslog-level?
!
! levels->syslog-mask
! (syslog-mask :syntax)
! syslog-mask-all
! syslog-mask-upto
! syslog-mask-levels-on?
!
! open-syslog-channel
! close-syslog-channel
! syslog-write
!
! with-syslog-destination
! syslog))
Index: scsh-package.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/scsh-package.scm,v
retrieving revision 1.18
retrieving revision 1.19
diff -C2 -r1.18 -r1.19
*** scsh-package.scm 2001/04/09 19:34:48 1.18
--- scsh-package.scm 2001/06/01 16:22:26 1.19
***************
*** 168,171 ****
--- 168,174 ----
tty-flags
scsh-internal-tty-flags ; Not exported
+
+ syslog
+
let-opt ; optional-arg parsing & defaulting
***************
*** 451,452 ****
--- 454,462 ----
threads) ; sleep
(files dot-locking))
+
+ (define-structure syslog syslog-interface
+ (open scheme define-record-types finite-types
+ locks thread-fluids
+ external-calls
+ bitwise)
+ (files syslog))
Index: syscalls.c
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/syscalls.c,v
retrieving revision 1.11
retrieving revision 1.12
diff -C2 -r1.11 -r1.12
*** syscalls.c 2001/01/09 15:57:06 1.11
--- syscalls.c 2001/06/01 16:22:26 1.12
***************
*** 888,893 ****
S48_EXPORT_FUNCTION(df_errno_msg);
S48_EXPORT_FUNCTION(scm_crypt);
- S48_EXPORT_FUNCTION(scm_openlog);
- S48_EXPORT_FUNCTION(scm_syslog);
- S48_EXPORT_FUNCTION(scm_closelog);
}
--- 888,890 ----
Index: syscalls.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/syscalls.scm,v
retrieving revision 1.18
retrieving revision 1.19
diff -C2 -r1.18 -r1.19
*** syscalls.scm 2001/01/09 15:55:03 1.18
--- syscalls.scm 2001/06/01 16:22:26 1.19
***************
*** 945,1017 ****
(if (> (string-length key) 8) (error "key too long " (string-length
key)))
(%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))
\ No newline at end of file
--- 945,946 ----
|