source: project/release/3/logging/trunk/logging-files.scm @ 9142

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

Fix for test stmp port, fix for import of remove dotfiles.

File size: 5.5 KB
Line 
1;;;; logging-files.scm
2;;;; Kon Lovett, Sep '06
3
4(eval-when (compile)
5  (declare
6                (usual-integrations)
7        (fixnum)
8        (inline)
9                (no-procedure-checks)
10                (no-bound-checks)
11        (export
12                        logbook-file-archive
13                        logbook-file-delete
14                        logbook-file-purge
15                        logbook-file-rotate
16                        logbook-catalog-load
17                        logbook-catalog-merge
18                        logbook-catalog-store) ) )
19
20(use srfi-1 srfi-18 utils posix)
21(use lookup-table synch misc-extn-record misc-extn-posix misc-extn-directory miscmacros z3 s11n)
22(use logging-catalogs logging-errors logging-objects logging-operations logging-parameters)
23
24;;;
25
26(include "logging-record-types")
27
28;;; Argument Checking
29
30(define (check-string obj loc)
31        (unless (string? obj)
32                (log$error loc "invalid string" obj)) )
33
34(define (check-log obj loc)
35        (unless (%log? obj)
36                (log$error loc "invalid logbook" obj)) )
37
38;;; Catalog support
39
40(define-inline (catalog-dictionary cat)
41        (mutex-specific cat) )
42
43;;; Logger Dictionary
44
45(define-inline-unchecked-record-type logger-dictionary
46        (make-logger-dictionary sources fields levels entries logs)
47        logger-dictionary?
48        (sources logger-dictionary-sources)
49        (fields logger-dictionary-fields)
50        (levels logger-dictionary-levels)
51        (entries logger-dictionary-entries)
52        (logs logger-dictionary-logs) )
53
54(define-inline (load-logger-dictionary port)
55        (deserialize port) )
56
57(define-inline (store-logger-dictionary ld port)
58        (serialize ld port) )
59
60;;; Logger Catalog
61
62(define-inline (load-logger-catalog port)
63        (let ([ld (load-logger-dictionary port)])
64                (log$fill-catalog
65                        (logger-dictionary-sources ld)
66                        (logger-dictionary-fields ld)
67                        (logger-dictionary-levels ld)
68                        (logger-dictionary-entries ld)
69                        (logger-dictionary-logs ld)) ) )
70
71(define-inline (store-logger-catalog port)
72        (let (
73                        [ld
74                                (make-logger-dictionary
75                                        (catalog-dictionary log$source-catalog->source)
76                                        (catalog-dictionary log$field-catalog->field)
77                                        (catalog-dictionary log$level-catalog->level)
78                                        (catalog-dictionary log$entry-catalog->entry)
79                                        (catalog-dictionary log$log-catalog->log))])
80                (store-logger-dictionary ld port) ) )
81
82;;; Logbook Archive
83
84;;
85
86(define (make-log-archive-pathname pathname verstr)
87        (let-values (([dir file ext] (decompose-pathname pathname)))
88                (make-pathname dir file (string-append ext "." verstr ".gz")) ) )
89
90(define (logbook-archive-files pathname)
91        (remove-dotfiles (glob (make-log-archive-pathname pathname "*"))) )
92
93(define-inline (last-log-archive-file-number pathname)
94        (add1
95                (reduce
96                        (lambda (pn n)
97                                (max n (string->number (pathname-extension (pathname-file pn)))))
98                        -1
99                        (logbook-archive-files pathname))) )
100
101;;
102
103(define (logbook-file-archive log #!optional (pathname (%log-pathname log)))
104        (check-log log 'logbook-file-archive)
105        (let ([errors (log$make-errors)])
106                (synch/log log
107                        (unless (log$log-force-close log errors)
108                                (log$errors 'logbook-file-archive "cannot close log file" (errors)))
109                        (when (file-exists? pathname)
110                                (let* ([fd
111                                                                (file-open
112                                                                        (make-log-archive-pathname pathname
113                                                                                (last-log-archive-file-number pathname))
114                                                                        (+ open/trunc open/wronly))]
115                                                         [z3
116                                                                (z3:encode-file fd #:level 8
117                                                                        #:filename pathname #:comment "logbook archive")])
118                                        (let ([contents (read-all pathname)])
119                                                (z3:write-encoded z3 contents)
120                                                (z3:write-encoded z3 #f)
121                                                (file-close fd) ) ) ) ) ) )
122
123(define (logbook-file-delete log #!optional (pathname (%log-pathname log)))
124        (check-log log 'logbook-file-delete)
125        (let ([errors (log$make-errors)])
126                (synch/log log
127                        (unless (log$log-force-close log errors)
128                                (log$errors 'logbook-file-delete "cannot close log file" (errors)))
129                        (when (file-exists? pathname)
130                                (delete-file pathname)) ) ) )
131
132(define (logbook-file-purge log #!optional (pathname (%log-pathname log)))
133        (check-log log 'logbook-file-purge)
134        (let ([errors (log$make-errors)])
135                (synch/log log
136                        (unless (log$log-force-close log errors)
137                                (log$errors 'logbook-file-purge "cannot close log file" (errors)))
138                        (when (file-exists? pathname)
139                                (delete-file pathname))
140                        (for-each delete-file (logbook-archive-files pathname) ) ) ) )
141
142(define (logbook-file-rotate log #!optional (pathname (%log-pathname log)))
143        (logbook-file-archive log pathname)
144        (logbook-file-delete log pathname) )
145
146;;; Catalog File
147
148(define (logbook-catalog-load #!optional (pathname (default-logbook-catalog)))
149        (check-string pathname 'logbook-catalog-load)
150        (and (file-exists? pathname)
151                (let ([port (open-input-file pathname)])
152                        (load-logger-catalog port)
153                        (close-input-port port)
154                        #t ) ) )
155
156(define (logbook-catalog-merge #!optional (pathname (default-logbook-catalog)))
157
158        (define (merge add! dict)
159                (dict-for-each dict (lambda (key value) (add! value))) )
160
161        (check-string pathname 'logbook-catalog-merge)
162        (if (file-exists? pathname)
163      (let* ([port (open-input-file pathname)]
164             [ld (load-logger-dictionary port)])
165        (close-input-port port)
166        (merge logbook-source-add! (logger-dictionary-sources ld))
167        (merge logbook-level-add! (logger-dictionary-levels ld))
168        (merge logbook-field-add! (logger-dictionary-fields ld))
169        (merge logbook-entry-add! (logger-dictionary-entries ld))
170        (merge logbook-add! (logger-dictionary-logs ld))
171        #t ) )
172      (log$error 'logbook-catalog-merge "no such catalog file" pathname) )
173
174(define (logbook-catalog-store #!optional (pathname (default-logbook-catalog)))
175        (check-string pathname 'logbook-catalog-store)
176        (when (file-exists? pathname)
177                (delete-file pathname))
178        (let ([port (open-output-file pathname)])
179                (store-logger-catalog port)
180                (close-output-port port)
181                #t ) )
Note: See TracBrowser for help on using the repository browser.