source: project/release/3/logging/trunk/logging-operations.scm @ 9025

Last change on this file since 9025 was 9025, checked in by Kon Lovett, 12 years ago

Canon dir struct

File size: 4.7 KB
Line 
1;;;; logging-operations.scm
2;;;; Kon Lovett, Sep '06
3
4(use srfi-1 srfi-13 srfi-18 utils posix extras)
5(use lookup-table synch misc-extn-list miscmacros uri)
6(use logging-errors logging-parameters)
7
8(eval-when (compile)
9  (declare
10        (fixnum)
11        (inline)
12        (export
13                        log$*operations*
14                        log$log-string
15                        log$log-force-open
16                        log$log-force-close) ) )
17
18;;;
19
20(include "logging-record-types")
21
22;;;
23
24(define-macro (synch/lock-log REC . BODY)
25        `(synch/lock-record %log ,REC ,@BODY) )
26
27(define-macro (synch/unlock-log REC . BODY)
28        `(synch/unlock-record %log ,REC ,@BODY) )
29
30;;; Log Filesystem Accessors
31
32;; This no work; modes are never compatible!
33
34#;(define *open-mode* (bitwise-ior open/excl open/text open/append))
35#;(define *create-mode* (bitwise-ior open/creat *open-mode*))
36
37#;(define (open-port pathname errors)
38        (let/cc return
39                (with-exception-handler
40                        (lambda (exp)
41                                (errors 'open-port (list exp pathname))
42                                (return #f))
43                        (lambda ()
44                                (let* (
45                                                [flags (if (file-exists? pathname) *open-mode* *create-mode*)]
46                                                [fileno (file-open pathname flags (default-file-permissions))]
47                                                [port (open-output-file* fileno #:append)])
48                                        (set-port-name! port pathname)
49                                        port ) ) ) ) )
50
51(define (open-port pathname errors)
52        (let/cc return
53                (with-exception-handler
54                        (lambda (exp)
55                                (errors 'open-port (list exp pathname))
56                                (return #f))
57                        (lambda ()
58                                (open-output-file pathname #:text #:append) ) ) ) )
59
60(define (close-port port errors)
61        (let/cc return
62                (with-exception-handler
63                        (lambda (exp)
64                                (errors 'close-port (list exp (port-name port)))
65                                (return #f))
66                        (lambda ()
67                                (close-output-port port)
68                                #t ) ) ) )
69
70(define write-port
71        (let ([nlstr (string #\newline)])
72                (lambda (port str errors)
73                        (let/cc return
74                                (with-exception-handler
75                                        (lambda (exp)
76                                                (errors 'write-port (list exp (port-name port)))
77                                                (return #f))
78                                        (lambda ()
79                                                (display str port)
80                                                (unless (string-suffix? str nlstr)
81                                                        (newline port) )
82                                                (flush-output port)
83                                                #t ) ) ) ) ) )
84
85;;;
86
87;;
88
89(define-inline (%log-open log pathname errors)
90        ((%logbook-operations-open (%log-operations log)) pathname errors) )
91
92(define-inline (%log-close log port errors)
93        ((%logbook-operations-close (%log-operations log)) port errors) )
94
95(define-inline (%log-write log port str errors)
96        ((%logbook-operations-write (%log-operations log)) port str errors) )
97
98;;
99
100(define (log$log-open log open? errors)
101        (unless (%log-uri log)
102                (let ([port (%log-port log)])
103                        (or port
104                                (and open?
105                                        (let ([port (%log-open log (%log-pathname log) errors)])
106                                                (and port
107                                                        (begin
108                                                                (%log-port-set! log port)
109                                                                port ) ) ) ) ) ) ) )
110
111(define (log$log-close log errors)
112        (unless (%log-uri log)
113                (let ([port (%log-port log)])
114                        (and port
115                                (%log-close log port errors)
116                                (begin
117                                        (%log-port-set! log #f)
118                                        #t ) ) ) ) )
119
120(define-inline (log$log-to-uri log str errors)
121        (let* ([scheme (uri-scheme (%log-uri log))]
122                                 [proc (logbook-uri-scheme-handler scheme)])
123                (if proc
124                        (proc log str errors)
125                        (begin
126                                (errors 'log-to-uri (list "unrecognized uri scheme" scheme))
127                                #f) ) ) )
128
129(define-inline (log$log-write log str errors)
130        (if (%log-uri log)
131                (log$log-to-uri log str errors)
132                (let ([port (%log-port log)])
133                        (and port
134                                (%log-write log port str errors) ) ) ) )
135
136;;; Open multiple logs
137
138;; Returns (log) or () with the log locked
139
140(define (open-log-or-alternate log alternates open? errors)
141        (if (synch/lock-log log (log$log-open log open? errors))
142                (list log)
143                (reduce
144                        (lambda (alt lst)
145                                (or (not-null? lst)
146                                        (and (synch/lock-log alt (log$log-open alt open? errors))
147                                                (list alt))))
148                        '()
149                        alternates ) ) )
150
151;; Returns (log ...) or ()
152
153(define-inline (open-log-ports log echos alternates open? errors)
154        (apply append
155                (open-log-or-alternate log alternates open? errors)
156                (map
157                        (lambda (echo)
158                                (open-log-or-alternate echo '() open? errors))
159                        echos)) )
160
161(define (write-log log str errors)
162        (synch/unlock-log log
163                (let ([wrote? (log$log-write log str errors)])
164                        (unless (or (%log-session-open? log) (%log-keep-open? log) wrote?)
165                                (log$log-close log errors) )
166                        wrote? ) ) )
167
168;;; Logger Internal Operations API
169
170(define log$*operations*
171        (%make-logbook-operations open-port close-port write-port))
172
173(define (log$log-string log errors str echos alternates open?)
174        (let ([open-logs (open-log-ports log echos alternates open? errors)])
175                (and (not-null? open-logs)
176                        (reduce
177                                (lambda (x a) (and x a))
178                                #t
179                                (map! (cut write-log <> str errors) open-logs))) ) )
180
181(define (log$log-force-open log errors)
182        (synch/log log
183                (unless (%log-keep-open? log)
184                        (%log-session-open-set! log #t) )
185                (log$log-open log #t errors) ) )
186
187(define (log$log-force-close log errors)
188        (synch/log log
189                (%log-session-open-set! log #f)
190                (log$log-close log errors) ) )
Note: See TracBrowser for help on using the repository browser.