Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-17 09:57:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

portability fixes for (chibi log)

Browse source
This commit is contained in:
Alex Shinn 2016-09-28 23:24:08 +09:00
parent 6b5c2c3d0b
commit 70c85542e2
2 changed files with 16 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
lib/chibi/log.scm
View file

@ -63,7 +63,7 @@
(define (log-normalize-name name) (define (log-normalize-name name)
(let ((str (symbol->string name))) (let ((str (symbol->string name)))
(if (string-prefix? "log-" str) (if (string-prefix? "log-" str)
(string->symbol (substring str 4)) (string->symbol (substring str 4 (string-length str)))
name))) name)))
(define (log-level-index logger level) (define (log-level-index logger level)
@ -115,8 +115,8 @@
(message (show #f (each-in-list args)))) (message (show #f (each-in-list args))))
(string-append (string-append
prefix prefix
(string-concatenate (string-split message #\newline) (string-join (string-split message #\newline)
(string-append "\n" prefix)) (string-append "\n" prefix))
"\n"))) "\n")))
(define (log-compile-prefix spec) (define (log-compile-prefix spec)
@ -148,7 +148,7 @@
(let ((time (seconds->time (current-seconds)))) (let ((time (seconds->time (current-seconds))))
(let lp ((ls procs) (res '())) (let lp ((ls procs) (res '()))
(if (null? ls) (if (null? ls)
(string-concatenate (reverse res)) (string-join (reverse res))
(lp (cdr ls) (cons ((car ls) logger time level) res)))))))) (lp (cdr ls) (cons ((car ls) logger time level) res))))))))
(define log-default-prefix (define log-default-prefix
@ -162,7 +162,8 @@
(logger-port-set! logger (current-error-port)))) (logger-port-set! logger (current-error-port))))
(define (log-close logger) (define (log-close logger)
(if (output-port? (logger-port logger)) (if (and (output-port? (logger-port logger))
(not (eq? (current-error-port) (logger-port logger))))
(close-output-port (logger-port logger)))) (close-output-port (logger-port logger))))
;; Use file-locking to let multiple processes write to the same log ;; Use file-locking to let multiple processes write to the same log
@ -185,13 +186,13 @@
(log-open logger) (log-open logger)
(lp #f)) (lp #f))
(else ; fall back to stderr (else ; fall back to stderr
(display str (current-error-port)))))) (write-string str (current-error-port))))))
(let ((locked? (and (logger-locked? logger) (let ((locked? (and (logger-locked? logger)
(output-port? out) (output-port? out)
(file-lock out lock/exclusive)))) (file-lock out lock/exclusive))))
;; this is redundant with POSIX O_APPEND ;; this is redundant with POSIX O_APPEND
;; (set-file-position! out 0 seek/end) ;; (set-file-position! out 0 seek/end)
(display str out) (write-string str out)
(flush-output out) (flush-output out)
(if locked? (file-lock out lock/unlock)))))))))) (if locked? (file-lock out lock/unlock))))))))))

10
lib/chibi/log.sld
View file

@ -24,16 +24,22 @@
(import (chibi time) (chibi string) (chibi show base)) (import (chibi time) (chibi string) (chibi show base))
(cond-expand (cond-expand
(chibi (chibi
(import (chibi) (chibi filesystem) (chibi process) (chibi system) (srfi 9)) (import (chibi) (chibi filesystem) (chibi process) (chibi string)
(chibi system) (srfi 9))
(begin (begin
(define write-string display)
(define (open-output-file/append path) (define (open-output-file/append path)
(let ((fd (open path (let ((fd (open path
(+ open/create open/write open/append open/non-block)))) (+ open/create open/write open/append open/non-block))))
(open-output-file-descriptor fd))))) (open-output-file-descriptor fd)))))
(else (else
(import (scheme base)) (import (scheme base) (scheme char) (scheme file) (chibi string))
(begin (begin
(define-syntax protect
(syntax-rules ()
((protect . x) (guard . x))))
(define open-output-file/append open-output-file) (define open-output-file/append open-output-file)
(define flush-output flush-output-port)
(define (file-lock port-or-fileno mode) 'unsupported) (define (file-lock port-or-fileno mode) 'unsupported)
(define lock/exclusive 'unsupported) (define lock/exclusive 'unsupported)
(define lock/unlock 'unsupported) (define lock/unlock 'unsupported)