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

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

Canon dir struct

File size: 5.4 KB
Line 
1;;;; logging-files.scm
2;;;; Kon Lovett, Sep '06
3
4(use srfi-1 srfi-18 utils posix)
5(use lookup-table synch misc-extn-record misc-extn-posix miscmacros z3 s11n)
6(use logging-catalogs logging-errors logging-objects logging-operations logging-parameters)
7
8(eval-when (compile)
9  (declare
10                (usual-integrations)
11        (fixnum)
12        (inline)
13                (no-procedure-checks)
14                (no-bound-checks)
15        (export
16                        logbook-file-archive
17                        logbook-file-delete
18                        logbook-file-purge
19                        logbook-file-rotate
20                        logbook-catalog-load
21                        logbook-catalog-merge
22                        logbook-catalog-store) ) )
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                        (let ([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.