source: project/release/3/logging/trunk/logging.scm @ 9026

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

Rel 1.0.0 (no real changes)

File size: 39.0 KB
Line 
1;;;; logging.scm
2;;;; Kon Lovett, Sep '06
3
4;; Issues
5;;
6;; - No ability to update/extend fields of a log object.
7;;
8;; (log-attach log #:echos #:alternates #:asynch)
9;;
10;; - Better formatting objects: Raw, XTerm_Color, VT100_Color, ...
11;;
12;; - Should lock log object at start of process rather than piecemeal.
13;;
14;; - Should unify log+alternates, echos & asynch as Appenders?
15;;
16;; - Sources & entries in logs for allowed items checking.
17;;
18;;              - Trying w/o entries since a pain in practice.
19;;
20;; - No mapping of source, fields to syslog entry components. Mapping of
21;; levels is kludgy.
22;;
23;; - No log file permissions.
24;;
25;; - No localization.
26;;
27;; - Should explicitly close all open log ports at shutdown.
28;;
29;; - A field can be a procedure; so must serialize. But serialize doesn't preserve
30;; identity so xref of log -> entry/source/level & entry -> field/level will duplicate
31;; the items; i.e. the one in the catalog will not be the same object as the previously
32;; xref'ed.
33;;
34;;              - Grouping all catalog dictionaries in a single record type.
35
36(eval-when (compile)
37  (declare
38        (usual-integrations)
39        (fixnum)
40        (inline)
41                (no-procedure-checks)
42                (no-bound-checks)
43        (bound-to-procedure
44                        fields->strings
45                        pid-field)
46        (export
47                make-log-mail-string
48                        make-logbook-operations
49                        make-logbook-source
50                        make-logbook-field
51                        make-logbook-level
52                        make-logbook-entry
53                        clone-logbook-entry
54                        make-logbook
55                        clone-logbook
56                        new-logbook-source
57                        new-logbook-field
58                        new-logbook-level
59                        new-logbook-entry
60                        clone-new-logbook-entry
61                        new-logbook
62                        clone-new-logbook
63                        logbook-level
64                        set-logbook-level!
65                        logbook-level-mask
66                        set-logbook-level-mask!
67                        %make-log-string
68                        make-log-string
69                        open-logbook
70                        close-logbook
71                        %log-string
72                        log-string
73                        log-message
74                        log-format ) ) )
75
76(use srfi-1 srfi-13 srfi-18 utils posix extras regex)
77(use lookup-table synch
78     misc-extn-list misc-extn-posix misc-extn-dsssl
79     miscmacros mailbox mathh-int uri smtp)
80(use logging-errors logging-catalogs logging-operations logging-parameters)
81
82;;;
83
84#+unix
85#>
86#include <syslog.h>
87#include <stdarg.h>
88
89static int syslog_level = LOG_INFO;
90/*static int syslog_facility = LOG_USER;*/
91
92static
93void syslog_set_level (int level/*, int source*/)
94{
95        switch (level) {
96                case 0: syslog_level = LOG_EMERG; break;
97                case 1: syslog_level = LOG_ALERT; break;
98                case 2: syslog_level = LOG_CRIT; break;
99                case 3: syslog_level = LOG_ERR; break;
100                case 4: syslog_level = LOG_WARNING; break;
101                case 5: syslog_level = LOG_NOTICE; break;
102                case 6: syslog_level = LOG_INFO; break;
103                case 7: syslog_level = LOG_DEBUG; break;
104                default: syslog_level = LOG_INFO; break;
105        }
106}
107
108static
109int syslog_str (const char *str)
110{
111        syslog (syslog_level | LOG_USER, "%s", str);
112        return 1;
113}
114<#
115
116;;;
117
118(include "logging-constants")
119
120(include "logging-record-types")
121
122(include "logging-argument-checking")
123
124;;; Constants
125
126;; Should use current locale (use srfi-19?)
127
128(define *month-abbreviations*
129        '#("Jan" "Feb" "Mar" "Apr" "May" "Jun"
130                 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
131
132;;; Record Types
133
134;;
135
136(define (make-source id mutable? name)
137        (let ([source (%make-source id mutable? name)])
138                (%source-mutex-set! source (make-mutex id))
139                source ) )
140
141(define-record-printer (source x out)
142        (fprintf out "#,(source ~S ~S ~S)"
143                (%source-id x)
144                (%source-mutable? x)
145                (%source-name x)) )
146
147(define-reader-ctor 'source
148  (lambda (id mutable? name)
149    (make-source id mutable? name)))
150
151;;
152
153(define (make-level id mutable? name priority)
154        (let ([level (%make-level id mutable? name priority)])
155                (%level-mutex-set! level (make-mutex id))
156                level ) )
157
158(define-record-printer (level x out)
159        (fprintf out "#,(level ~S ~S ~S ~S)"
160                (%level-id x)
161                (%level-mutable? x)
162                (%level-name x)
163                (%level-priority x)) )
164
165(define-reader-ctor 'level
166  (lambda (id mutable? name priority)
167    (make-level id mutable? name priority)))
168
169(define-inline (level<=? l1 l2)
170        (<= (%level-priority l1) (%level-priority l2)) )
171
172;;
173
174(define (make-field id mutable? value)
175        (let ([field (%make-field id mutable? value)])
176                (%field-mutex-set! field (make-mutex id))
177                field ) )
178
179(define-record-printer (field x out)
180        (fprintf out "#,(field ~S ~S ~S)"
181                (%field-id x)
182                (%field-mutable? x)
183                (%field-value x)) )
184
185(define-reader-ctor 'field
186  (lambda (id mutable? value)
187    (make-field id mutable? value)))
188
189;;
190
191(define (make-entry id mutable? indent level fields)
192        (let ([entry (%make-entry id mutable? indent level fields)])
193                (%entry-mutex-set! entry (make-mutex id))
194                entry ) )
195
196(define-record-printer (entry x out)
197        (fprintf out "#,(entry ~S ~S ~S ~S ~S)"
198                (%entry-id x)
199                (%entry-mutable? x)
200                (%entry-indent x)
201                (%entry-level x)
202                (%entry-fields x)) )
203
204(define-reader-ctor 'entry
205  (lambda (id mutable? indent level fields)
206    (make-entry id mutable? indent level fields)))
207
208(define (clone-entry entry id mutable? indent level fields)
209        (synch/entry entry
210                (make-entry id
211                        (optional-entry-value entry mutable?)
212                        (optional-entry-value entry indent)
213                        (optional-entry-value entry level)
214                        (optional-entry-value entry fields)) ) )
215
216;;
217
218(define (make-logbook-operations open close write)
219        (check-procedure open 'make-logbook-operations)
220        (check-procedure close 'make-logbook-operations)
221        (check-procedure write 'make-logbook-operations)
222        (%make-logbook-operations open close write) )
223
224(define-record-printer (logbook-operations x out)
225        (fprintf out "#,(logbook-operations ~S ~S ~S)"
226                (%logbook-operations-open x)
227                (%logbook-operations-close x)
228                (%logbook-operations-write x)) )
229
230(define-reader-ctor 'logbook-operations
231  (lambda (open close write)
232    (let ([foo
233            (lambda args
234              (error 'logbook-operations "cannot recover from read-syntax"))])
235      (make-logbook-operations foo foo foo))))
236
237;;
238
239(define (uri-encode-path uri)
240  (uri-encode-split-path (uri-path uri)) )
241
242(define-inline (%log-uri-or-pathname-set! log pathname)
243        (%log-uri-set! log #f)
244        (when pathname
245                (let* ([obj (uri pathname)]
246                                         [scheme (uri-scheme obj)])
247                        (when scheme
248                                (switch scheme
249                                        ['file
250                                                (%log-pathname-set! log (uri-encode-path obj))]
251                                        [else
252                                                (%log-pathname-set! log #f)
253                                                (%log-uri-set! log obj)])))) )
254
255(define (make-log id
256                                        mutable?
257                                        pathname
258                                        sources
259                                        entry level
260                                        echos alternates
261                                        keep-open? immediate-open?
262                                        operations
263                                        asynchronous? asynchronous-error)
264        (let (
265                        [log
266                                (%make-log id
267                                        mutable?
268                                        pathname
269                                        (delete-duplicates sources eq?)
270                                        entry level
271                                        (delete-duplicates echos eq?)
272                                        (delete-duplicates alternates eq?)
273                                        keep-open?
274                                        immediate-open?
275                                        operations
276                                        asynchronous?
277                                        asynchronous-error)])
278                (%log-uri-or-pathname-set! log pathname)
279                (%log-session-open-set! log #f)
280                (%log-port-set! log #f)
281                (%log-mutex-set! log (make-mutex id))
282                (%log-fielder-set! log fields->strings)
283                (%log-level-mask-set! log '())
284                log ) )
285
286(define-record-printer (log x out)
287        (fprintf out "#,(log ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S ~S)"
288                (%log-id x)
289                (%log-mutable? x)
290                (%log-pathname x)
291                (%log-uri x)
292                (%log-sources x)
293                (%log-entry x)
294                (%log-level x)
295                (%log-level-mask x)
296                (%log-echos x)
297                (%log-alternates x)
298                (%log-keep-open? x)
299                (%log-immediate-open? x)
300                (%log-operations x)
301                (%log-asynchronous? x)
302                (%log-asynchronous-error x)
303                (%log-fielder x)) )
304
305(define-reader-ctor 'log
306  (lambda (id mutable? pathname _uri sources entry level level-mask
307           echos alternates keep-open? immediate-open? operations
308           asynchronous? asynchronous-error fielder)
309    (let ([log
310            (make-log id
311              mutable?
312              pathname
313              sources
314              entry level
315              echos alternates
316              keep-open? immediate-open?
317              operations
318              asynchronous? asynchronous-error)])
319      (%log-level-mask-set! log level-mask)
320      log)))
321
322(define-inline (make-default-pathname)
323        (make-pathname (default-logbook-directory) "" (default-logbook-extension)) )
324
325(define (clone-pathname log cpn)
326        (let (
327                        [lpn (if (%log-uri log) (make-default-pathname) (%log-pathname log))])
328                (let-values (
329                                ([ldir lfil lext] (decompose-pathname lpn))
330                                ([cdir cfil cext] (decompose-pathname cpn)))
331                        (make-pathname (or cdir ldir) cfil (or cext lext))) ) )
332
333(define (clone-log log id
334                                        mutable?
335                                        pathname
336                                        sources
337                                        entry level
338                                        echos alternates
339                                        keep-open? immediate-open?
340                                        operations
341                                        asynchronous? asynchronous-error)
342        (%synch/log log
343                (make-log id
344                        (optional-log-value log mutable?)
345                        (and pathname (clone-pathname log pathname))
346                        (optional-log-value log sources)
347                        (optional-log-value log entry)
348                        (optional-log-value log level)
349                        (optional-log-value log echos)
350                        (optional-log-value log alternates)
351                        (optional-log-value log keep-open?)
352                        (optional-log-value log immediate-open?)
353                        (optional-log-value log operations)
354                        (optional-log-value log asynchronous?)
355                        (optional-log-value log asynchronous-error)) ) )
356
357(define (logable-level? log level)
358        (and (level<=? (%log-level log) level)
359                (let ([mask (%log-level-mask log)])
360                        (or (null? mask) (member level mask)))) )
361
362;;; Argument Checking
363
364;;
365
366(define (check-atom-or-list-of proc obj loc)
367        (if (list? obj)
368      (for-each (cut proc <> loc) obj)
369      (proc obj loc)) )
370
371(define (check-optional proc obj loc)
372        (unless (undefined? obj)
373                (proc obj loc)) )
374
375(define (check-boolean obj loc)
376        (unless (boolean? obj)
377                (log$error loc "invalid boolean" obj)) )
378
379(define (check-symbol obj loc)
380        (unless (symbol? obj)
381                (log$error loc "invalid symbol" obj)) )
382
383(define (check-string obj loc)
384        (unless (string? obj)
385                (log$error loc "invalid string" obj)) )
386
387(define (check-strings obj loc)
388        (check-atom-or-list-of check-string obj loc) )
389
390(define (check-procedure obj loc)
391        (unless (procedure? obj)
392                (log$error loc "invalid procedure" obj)) )
393
394#;(define (check-directory obj loc)
395        (unless (%directory-argument? obj)
396                (log$error loc "invalid directory name" obj)) )
397
398#;(define (check-filename obj loc)
399        (unless (%filename-argument? obj)
400                (log$error loc "invalid filename" obj)) )
401
402#;(define (check-extension obj loc)
403        (unless (%extension-argument? obj)
404                (log$error loc "invalid pathname extension" obj)) )
405
406(define (check-pathname-argument obj loc)
407        (unless (or (not obj) (string? obj))
408                (log$error loc "invalid pathname" obj)) )
409
410;;
411
412(define (check-field obj loc)
413        (unless (field-value? obj)
414                (log$error loc "invalid logbook field" obj)) )
415
416(define (check-fields obj loc)
417        (check-atom-or-list-of check-field obj loc) )
418
419(define (check-operations obj loc)
420        (unless (%logbook-operations? obj)
421                (log$error loc "invalid logbook operations" obj) ) )
422
423(define (check-indent obj loc)
424        (unless (and (fixnum? obj) (not (negative? obj)) (<= obj MAXIMUM-INDENT))
425                (log$error loc "invalid indent" obj)) )
426
427;;
428
429(define (check-source-argument obj loc)
430        (unless (%source-argument? obj)
431                (log$error loc "invalid logbook source" obj)) )
432
433(define (check-level-argument obj loc)
434        (unless (%level-argument? obj)
435                (log$error loc "invalid logbook level" obj)) )
436
437(define (check-entry-argument obj loc)
438        (unless (%entry-argument? obj)
439                (log$error loc "invalid logbook entry" obj)) )
440
441(define (check-log-argument obj loc)
442        (unless (%log-argument? obj)
443                (log$error loc "invalid logbook" obj)) )
444
445(define (check-logs-argument obj loc)
446        (check-atom-or-list-of check-log-argument obj loc) )
447
448(define (check-sources-argument obj loc)
449        (check-atom-or-list-of check-source-argument obj loc) )
450
451(define (check-levels-argument obj loc)
452        (check-atom-or-list-of check-level-argument obj loc) )
453
454;;
455
456(define (verify-source-for-sources source sources)
457        (unless (undefined? source)
458                (or (string? source)
459                        (memq source sources)) ) )
460
461(define (verify-source-for-log log source)
462        (%synch/log log
463                (verify-source-for-sources source (%log-sources log)) ) )
464
465(define (verify-level-for-entry entry level)
466        (unless (or (undefined? entry) (undefined? level))
467                (%synch/entry entry
468                        (eq? level (%entry-level entry)) ) ) )
469
470;;
471
472(define (check-source-for-log log source loc)
473        (unless (verify-source-for-log log source)
474                (log$error loc "invalid source for log" source log) ) )
475
476(define (check-level-for-entry entry level loc)
477        (unless (verify-level-for-entry entry level)
478                (log$error loc "invalid level for entry" level entry) ) )
479
480;;; Argument Resolution
481
482;;
483
484(define (most-specific-entry-item entry ref item default-item)
485        (if (or (not item) (undefined? item))
486      (or (and (not (undefined? entry))
487               (%synch/entry entry (ref entry)))
488          default-item)
489      item ) )
490
491(define (most-specific-log log ref logs default-logs)
492        (%synch/log log
493                (delete-duplicates!
494                        (append (ref log) (optional-value logs default-logs))
495                        eq?) ) )
496
497;;
498
499(define (most-specific-level entry level default-level)
500        (most-specific-entry-item entry
501                (lambda (entry) (%entry-level entry))
502                level default-level) )
503
504(define (most-specific-fields entry fields default-fields)
505        (most-specific-entry-item entry
506                (lambda (entry) (%entry-fields entry))
507                fields default-fields) )
508
509(define (most-specific-echos log echos default-echos)
510        (most-specific-log log
511                (lambda (log) (%log-echos log))
512                echos default-echos) )
513
514(define (most-specific-alternates log alternates default-alternates)
515        (most-specific-log log
516                (lambda (log) (%log-alternates log))
517                alternates default-alternates) )
518
519;;
520
521(define (resolve-object cat obj)
522        (if (symbol? obj)
523      (log$catalog-value cat obj)
524      obj ) )
525
526(define (resolve-objects proc obj)
527        (cond [(pair? obj) (map proc obj)]
528        [(list? obj) obj]
529        [(undefined? obj) obj]
530        [else (list (proc obj))] ) )
531
532;;
533
534(define (resolve-log-object obj)
535        (resolve-object log$log-catalog->log obj) )
536
537(define (resolve-entry-object obj)
538        (resolve-object log$entry-catalog->entry obj) )
539
540(define (resolve-level-object obj)
541        (resolve-object log$level-catalog->level obj) )
542
543(define (resolve-source-object obj)
544        (resolve-object log$source-catalog->source obj) )
545
546(define (resolve-log-objects obj)
547        (resolve-objects resolve-log-object obj) )
548
549(define (resolve-source-objects obj)
550        (resolve-objects resolve-source-object obj) )
551
552(define (resolve-entry-objects obj)
553        (resolve-objects resolve-entry-object obj) )
554
555(define (resolve-level-objects obj)
556        (resolve-objects log$level-catalog->level obj) )
557
558;;; Builtin Fields
559
560(define pid-field
561        (let ([pidstr #f])
562                (lambda ()
563                        (unless pidstr
564                                (set! pidstr (conc #\[ (number->string (current-process-id)) #\])) )
565                        pidstr ) ) )
566
567(define hostname-field
568        ; Can't cache the result, it could be changed.
569        get-host-name)
570
571(define (timestamp-field)
572        (let* (
573                        [timvec (seconds->local-time (current-seconds))]
574                        [monstr (vector-ref *month-abbreviations* (vector-ref timvec 4))]
575                        [intstr
576                                (lambda (idx prefix)
577                                        (let* ([itm (vector-ref timvec idx)]
578                                                                 [itmstr (number->string itm)])
579                                                (if (< itm 10)
580                (string-append/shared prefix itmstr)
581                itmstr ) ) )])
582                (string-append/shared
583                        monstr " " (number->string (vector-ref timvec 3))
584                        " "
585                        (intstr 2 "0") ":" (intstr 1 "0") ":" (intstr 0 "0")) ) )
586
587;;;
588
589(define (force-open-log log loc)
590        (let ([errors (log$make-errors)])
591                (unless (log$log-force-open log errors)
592                        (log$errors loc "cannot open log file" (errors)) ) ) )
593
594(define (force-close-log log loc)
595        (let ([errors (log$make-errors)])
596                (unless (log$log-force-close log errors)
597                        (log$errors loc "cannot close log file" (errors)) ) ) )
598
599;;; Create Logger Objects
600
601(define (make-logbook-pathname fil
602                                        #!key
603                                        (dir (default-logbook-directory))
604                                        (ext (default-logbook-extension)))
605        (make-pathname dir fil ext) )
606
607(define (make-logbook-source id #!optional (name (undefined-value)))
608        ;
609        (check-symbol id 'make-logbook-source)
610        (check-optional check-string name 'make-logbook-source)
611        ;
612        (make-source id #f (optional-value name (symbol->string id))) )
613
614(define (make-logbook-level id #!optional (priority 0) (name (undefined-value)))
615        ;
616        (check-symbol id 'make-logbook-level)
617        (check-optional check-string name 'make-logbook-level)
618        ;
619        (make-level id #f (optional-value name (symbol->string id)) priority) )
620
621(define (make-logbook-field id #!optional (value (undefined-value)))
622        ;
623        (check-symbol id 'make-logbook-field)
624        (check-optional check-field value 'make-logbook-field)
625        ;
626        (when (undefined? value)
627                (let ([proc (symbol-value id)])
628                        (check-procedure proc 'make-logbook-field)
629                        (set! value proc) ) )
630        ;
631        (make-field id #f value) )
632
633(define (make-logbook-entry id #!rest fields
634                                        #!key
635                                        (mutable? #f)
636                                        (indent 0)
637                                        (level (default-entry-level)))
638        ;
639        (set! fields
640              (fixup-extended-lambda-list-rest '(#:level #:indent #:mutable?)
641                                               fields))
642        ;
643        (check-symbol id 'make-logbook-entry)
644        (check-fields fields 'make-logbook-entry)
645        (check-level-argument level 'make-logbook-entry)
646        (check-indent indent 'make-logbook-entry)
647        ;
648        (make-entry id
649                mutable?
650                indent
651                (resolve-level-object level)
652                (or (not-null? fields) (default-entry-fields))) )
653
654(define (clone-logbook-entry entry id #!rest fields
655                                        #!key
656                                        (mutable? #f)
657                                        (indent (undefined-value))
658                                        (level (undefined-value)))
659        ;
660        (set! fields
661              (fixup-extended-lambda-list-rest '(#:level #:indent #:mutable?)
662                                               fields))
663        ;
664        (check-symbol id 'clone-logbook-entry)
665        (check-optional check-fields fields 'clone-logbook-entry)
666        (check-optional check-level-argument level 'clone-logbook-entry)
667        (check-optional check-indent indent 'clone-logbook-entry)
668        ;
669        (clone-entry (resolve-entry-object entry) id
670                mutable?
671                indent
672                (resolve-level-object level)
673                (if (null? fields)
674                    (undefined-value)
675                    fields)) )
676
677(define (make-logbook id
678                                        #!key
679                                        (mutable? #f)
680                                        (pathname (undefined-value))
681                                        (sources (default-logbook-sources))
682                                        (entry (default-logbook-entry))
683                                        (level (default-logbook-level))
684                                        (echos (default-logbook-echos))
685                                        (alternates (default-logbook-alternates))
686                                        (keep-open? #f)
687                                        (immediate-open? #f)
688                                        (operations log$*operations*)
689                                        (asynchronous? #f)
690                                        (asynchronous-error (undefined-value)))
691        ;
692        (check-symbol id 'make-logbook)
693        (check-boolean mutable? 'make-logbook)
694        (when (undefined? pathname)
695                (set! pathname (make-logbook-pathname (symbol->string id))))
696        (check-pathname-argument pathname 'make-logbook)
697        (check-boolean keep-open? 'make-logbook)
698        (check-boolean immediate-open? 'make-logbook)
699        (check-logs-argument alternates 'make-logbook)
700        (check-logs-argument echos 'make-logbook)
701        (check-sources-argument sources 'make-logbook)
702        (check-entry-argument entry 'make-logbook)
703        (check-level-argument level 'make-logbook)
704        (check-operations operations 'make-logbook)
705        (check-boolean asynchronous? 'make-logbook)
706        (check-optional check-procedure asynchronous-error 'make-logbook)
707        ;
708        (set! entries (resolve-entry-objects entries))
709        (set! entry (resolve-entry-object entry))
710        ;
711        (let (
712                        [log
713                                (make-log id
714                                        mutable?
715                                        pathname
716                                        (resolve-source-objects sources)
717                                        entry
718                                        (resolve-level-object level)
719                                        (resolve-log-objects echos) (resolve-log-objects alternates)
720                                        keep-open? immediate-open?
721                                        operations
722                                        asynchronous? asynchronous-error)])
723                (when (%log-immediate-open? log)
724                        (force-open-log log 'make-logbook) )
725                log ) )
726
727(define (clone-logbook log id
728                                        #!key
729                                        (mutable? #f)
730                                        (pathname (undefined-value))
731                                        (sources (undefined-value))
732                                        (entry (undefined-value))
733                                        (level (undefined-value))
734                                        (echos (undefined-value))
735                                        (alternates (undefined-value))
736                                        (keep-open? (undefined-value))
737                                        (immediate-open? (undefined-value))
738                                        (operations (undefined-value))
739                                        (asynchronous? (undefined-value))
740                                        (asynchronous-error (undefined-value)))
741        ;
742        (check-log-argument log 'clone-logbook)
743        (check-symbol id 'clone-logbook)
744        (check-boolean mutable? 'clone-logbook)
745        (set! pathname (optional-value pathname (symbol->string id)))
746        (check-pathname-argument pathname 'clone-logbook)
747        (check-optional check-boolean keep-open? 'clone-logbook)
748        (check-optional check-boolean immediate-open? 'clone-logbook)
749        (check-optional check-logs-argument alternates 'clone-logbook)
750        (check-optional check-logs-argument echos 'clone-logbook)
751        (check-optional check-sources-argument sources 'clone-logbook)
752        (check-optional check-entry-argument entry 'clone-logbook)
753        (check-optional check-level-argument level 'clone-logbook)
754        (check-optional check-boolean asynchronous? 'clone-logbook)
755        (check-optional check-procedure asynchronous-error 'clone-logbook)
756        ;
757        (let (
758                        [clone
759                                (clone-log (resolve-log-object log) id
760                                        mutable?
761                                        pathname
762                                        (resolve-source-objects sources)
763                                        (resolve-entry-object entry)
764                                        (resolve-level-object level)
765                                        (resolve-log-objects echos) (resolve-log-objects alternates)
766                                        keep-open? immediate-open?
767                                        operations
768                                        asynchronous? asynchronous-error)])
769                (when (%log-immediate-open? clone)
770                        (force-open-log clone 'clone-logbook))
771                clone ) )
772
773;;; Create Logger Objects In Catalog
774
775(define (new-logbook-source id . args)
776        (let ([source (apply make-logbook-source id args)])
777                (log$catalog-add! log$source-catalog->source id source 'new-logbook-source)
778                source ) )
779
780(define (new-logbook-field id . args)
781        (let ([field (apply make-logbook-field id args)])
782                (log$catalog-add! log$field-catalog->field id field 'new-logbook-field)
783                field ) )
784
785(define (new-logbook-level id . args)
786        (let ([level (apply make-logbook-level id args)])
787                (log$catalog-add! log$level-catalog->level id level 'new-logbook-level)
788                level ) )
789
790(define (new-logbook-entry id . args)
791        (let ([entry (apply make-logbook-entry id args)])
792                (log$catalog-add! log$entry-catalog->entry id entry 'new-logbook-entry)
793                entry ) )
794
795(define (clone-new-logbook-entry entry id . args)
796        (let ([entry (apply clone-logbook-entry entry id args)])
797                (log$catalog-add! log$entry-catalog->entry id entry 'clone-new-logbook-entry)
798                entry ) )
799
800(define (new-logbook id . args)
801        (let ([log (apply make-logbook id args)])
802                (log$catalog-add! log$log-catalog->log id log 'new-logbook)
803                log ) )
804
805(define (clone-new-logbook log id . args)
806        (let ([clone (apply clone-logbook log id args)])
807                (log$catalog-add! log$log-catalog->log id clone 'clone-new-logbook)
808                clone ) )
809
810;;; Special Logs
811
812;; console
813
814(define (create-console-log)
815        (new-logbook 'console
816                #:pathname "/dev/console"
817                #:echos '()
818                #:alternates '()
819                #:keep-open? #f) )
820
821;; syslog
822
823#+unix
824(define (create-system-log)
825        (new-logbook-entry 'system-message '(? source " ") '(? level " "))
826        (let (
827                        [log
828                                (new-logbook 'system
829                                        #:pathname #f
830                                        #:entry 'system-message
831                                        #:echos '()
832                                        #:alternates '()
833                                        #:keep-open? #t
834                                        #:operations
835                                                (make-logbook-operations
836                                                        (lambda (pathname errors)
837                                                                #t )
838                                                        (lambda (port errors)
839                                                                #t )
840                                                        (lambda (port str errors)
841                                                                ($ bool syslog_str (c-string str)) ) ) )])
842                ; A kludge
843                (%log-fielder-set! log
844                        (lambda (source level fields)
845                                (let (
846                                                [ilvl
847                                                        (switch (%level-id level)
848                                                                ['emergency 0]
849                                                                ['alert 1]
850                                                                ['critical 2]
851                                                                ['error 3]
852                                                                ['warning 4]
853                                                                ['notice 5]
854                                                                ['info 6]
855                                                                ['debug 7]
856                                                                [else 6])])
857                                        ($ syslog_set_level (int ilvl))
858                                        (fields->strings source level fields)))) ) )
859
860;; stderr
861
862(define (create-error-log)
863        (new-logbook 'error
864                #:pathname #f
865                #:echos '()
866                #:alternates '()
867                #:keep-open? #t
868                #:operations
869                        (make-logbook-operations
870                                (lambda (pathname errors)
871                                        (current-error-port) )
872                                (lambda (port errors)
873                                        ;FIXME this is probably not a good idea
874                                        (close-output-port port)
875                                        #t )
876                                (%logbook-operations-write log$*operations*))) )
877
878;; Object Slot Access
879
880(define (logbook-level log)
881        (check-log-argument log 'logbook-level)
882        (%log-level (resolve-log-object log)) )
883
884(define (set-logbook-level! log level)
885        (check-log-argument log 'set-logbook-level!)
886        (check-level-argument level 'set-logbook-level!)
887        (%log-level-set!
888                (resolve-log-object log)
889                (resolve-level-object level)) )
890
891(define (logbook-level-mask log)
892        (check-log-argument log 'logbook-level-mask)
893        (%log-level-mask (resolve-log-object log)) )
894
895(define (set-logbook-level-mask! log . levels)
896        (check-log-argument log 'set-logbook-level-mask!)
897        (check-levels-argument levels 'set-logbook-level-mask!)
898        (%log-level-mask-set!
899                (resolve-log-object log)
900                (resolve-level-objects levels)) )
901
902;;; Message Construction
903
904(define indent->string
905        (let (
906                        [spcstr (make-string (* MAXIMUM-INDENT MAXIMUM-INDENT-AMOUNT) #\space)])
907                (lambda (indent)
908                        (if (positive? indent)
909          (let ([len (* indent (current-logbook-indent-amount))])
910            (substring/shared spcstr 0 len) )
911          "") ) ) )
912
913(define-inline (level->string level)
914        (if (%level? level)
915      (%level-name level)
916      level ) )
917
918(define-inline (source->string source)
919        (if (%source? source)
920      (%source-name source)
921      source ) )
922
923(define (field->string source level field)
924        (let fld->str ([field field])
925                (cond [(string? field)
926            field]
927          [(%field? field)
928            (fld->str (%field-value field))]
929          [(symbol? field)
930            (switch field
931              ['source (source->string source)]
932              ['level (level->string level)]
933              [else
934                (let ([fld (log$catalog-ref log$field-catalog->field field)])
935                  (if fld
936                    (fld->str fld)
937                    (symbol->string field) ) )] )]
938          [(procedure? field)
939            (field)]
940          [(length>1? field)
941            (switch (car field)
942              ['quote
943                (symbol->string (cadr field))]
944              ['?
945                (let ([args (cdr field)])
946                  (let ([str (fld->str (car args))])
947                    (if (string-null? str)
948                      str
949                      (apply string-append/shared str (map fld->str (cdr args))) ) ) )]
950              [else
951                (->string field)] )]
952          [else
953            (->string field)]) ) )
954
955(define (fields->strings source level fields)
956        (cond [(null? fields) ""]
957        [(pair? fields) (map (cut field->string source level <>) fields)]
958        [else (list (field->string source level fields))] ) )
959
960;; (%make-log-string 0 "" "" '() str ...)
961
962(define (%make-log-string log indent source level fields . msgs)
963        (%synch/log log
964                (string-concatenate/shared
965                        `(,(indent->string indent)
966                                ,@((%log-fielder log) source level fields)
967                                ,@msgs)) ) )
968
969(define (*make-log-string log entry indent source level fields msgs loc)
970        ;
971        (check-level-for-entry entry level loc)
972        ;
973        (apply %make-log-string
974                log
975                (optional-entry-value entry indent)
976                source
977                level
978                (most-specific-fields entry fields (default-logbook-fields))
979                msgs) )
980
981(define (make-log-string #!rest msgs
982                                        #!key
983                                        (entry (undefined-value))
984                                        (indent 0)
985                                        (source (undefined-value))
986                                        (level (undefined-value))
987                                        (fields (undefined-value)))
988        (let ([log #f])
989                ;
990                (set! msgs
991                      (fixup-extended-lambda-list-rest '(#:indent #:entry #:source #:level #:fields)
992                                                       msgs))
993                        ;
994                        (if (and (pair? msgs) (%log-argument? (car msgs)))
995          (begin
996            (set! log (car msgs))
997            (set! msgs (pop! msgs)) )
998          (set! log (default-logbook)) )
999                ;
1000                (check-log-argument log 'log-string)
1001                (check-optional check-entry-argument entry 'make-log-string)
1002                (check-indent indent 'make-log-string)
1003                (check-optional check-source-argument source 'make-log-string)
1004                (check-optional check-level-argument level 'make-log-string)
1005                (check-optional check-fields fields 'make-log-string)
1006                (check-strings msgs 'make-log-string)
1007                ;
1008                (set! entry (resolve-entry-object entry))
1009                ;
1010                (*make-log-string (resolve-log-object log) entry
1011                        indent
1012                        (resolve-source-object
1013                                (optional-value source (default-logbook-source)))
1014                        (resolve-level-object
1015                                (most-specific-level entry level (default-logbook-level)))
1016                        fields msgs
1017                        'make-log-string) ) )
1018
1019;;; URI
1020
1021(define (make-log-mail-string log str)
1022        (let ([obj (%log-uri log)]
1023                                [mail-line-break "\r\n"])
1024                (if obj
1025        (let ([al (uri-query obj)]
1026              [from #f]
1027              [subject #f]
1028              [bdy '()]
1029              [make-mail-header-line
1030                (lambda (key val)
1031                  (string-append
1032                    (string-titlecase (->string key))
1033                    ": "
1034                    (->string val)
1035                    mail-line-break))])
1036          (let ([hdr
1037                  (map
1038                    (lambda (pair)
1039                      (let ([key (car pair)]
1040                            [val (cdr pair)])
1041                        (case key
1042                          [("body")
1043                            (set! body
1044                              (cons
1045                                (string-append (cdr pair) mail-line-break)
1046                                body))
1047                            ""]
1048                          [("from")
1049                            (set! from (cdr pair))
1050                            ""]
1051                          [("subject")
1052                            (set! subject (cdr pair))
1053                            ""]
1054                          [else
1055                            (make-mail-header-line key val)])))
1056                    (or al '()))])
1057            (values
1058              (string-split (uri-encode-path obj) ",")
1059              (or from (%log-id log))
1060              (string-append
1061                (list->string hdr)
1062                (make-mail-header-line "subject" (or subject str))
1063                mail-line-break
1064                (list->string bdy)
1065                (if subject "" (string-append str mail-line-break))) ) ) )
1066        (values '() "" "") ) ) )
1067
1068(define (log$mail-uri-handler log str errors)
1069        (let ([obj (%log-uri log)])
1070          ; Note that authority is not actually part of the mailto std RFC2368.
1071                (let ([auth (or (uri-authority obj) (default-mail-authority))])
1072                        (if auth
1073          (let ([host (second auth)]
1074                [port (third auth)])
1075            (let (
1076                [smtpc
1077                  (smtp:connect
1078                    host (get-host-name)
1079                    #f (or port DEFAULT-SMTP-PORT))])
1080              (receive [tos from cntnts] (make-log-mail-string log str)
1081                (with-output-to-port (apply smtp:open smtpc from tos)
1082                  (lambda () (display cntnts)))
1083                (smtp:disconnect smtpc)
1084                #t ) ) )
1085          (begin
1086            (errors 'mail-uri-handler "missing authority")
1087            #f) ) ) ) )
1088
1089;;; Asynchronous Logging
1090
1091(define asynchronous-logger-start! #f)
1092(define asynchronous-logger-send! #f)
1093(define asynchronous-logger-stop! #f)
1094
1095(let ([asynchronous-logger-thread #f])
1096
1097        (define (asynchronous-logger)
1098                (let ([todo (mailbox-receive! (thread-specific (current-thread)))])
1099                        (let ([action (car todo)]
1100                                                [args (cdr todo)])
1101                                (switch action
1102                                        ['quit
1103                                                (void)]
1104                                        ['write
1105                                                (let ([errors (log$make-errors)])
1106                                                        (let* ([log-args (cdr args)]
1107                                                                                 [log (car log-args)])
1108                                                                (unless (apply log$log-string log errors (cdr log-args))
1109                                                                        ((car args)
1110                                                                                (log$make-errors-condition
1111                                                                                        'asynchronous-logger "problem with log file" log (errors))) ) ) )
1112                                                (asynchronous-logger)]
1113                                        [else
1114                                                (log$error (thread-name (current-thread))
1115                                                        "unknown operation" todo)]) ) ) )
1116
1117        (set! asynchronous-logger-start!
1118                (lambda ()
1119                        (set! asynchronous-logger-thread
1120                                (make-thread asynchronous-logger 'asynchronous-logger))
1121                        (thread-specific-set! asynchronous-logger-thread
1122                                (make-mailbox 'asynchronous-logger-todo))
1123                        (thread-start! asynchronous-logger-thread) ) )
1124
1125        (set! asynchronous-logger-send!
1126                (lambda (obj)
1127                        (mailbox-send! (thread-specific asynchronous-logger-thread) obj) ) )
1128
1129        (set! asynchronous-logger-stop!
1130                (lambda ()
1131                        (asynchronous-logger-send! '(quit))
1132                        (thread-join! asynchronous-logger-thread) ) ) )
1133
1134;;; Logbook Write
1135
1136(define (%log-string log str
1137                                        #!optional
1138                                        (echos '())
1139                                        (alternates '())
1140                                        (open? #t)
1141                                        (asynchronous? #f)
1142                                        (asynchronous-error (undefined-value)))
1143        ;
1144        (if asynchronous?
1145      (asynchronous-logger-send!
1146        (list 'write
1147          (optional-value asynchronous-error
1148            (default-asynchronous-error))
1149          log str echos alternates open?))
1150      (let ([errors (log$make-errors)])
1151        (unless (log$log-string log errors str echos alternates open?)
1152          (log$errors '%log-string "problem with log file" log (errors)) ) ) ) )
1153
1154;; (log-string (str|log) (str|null) ...)
1155
1156(define (log-string str #!rest args
1157                                        #!key
1158                                        (source (undefined-value))
1159                                        (level (undefined-value))
1160                                        (echos (undefined-value))
1161                                        (alternates (undefined-value))
1162                                        (open? #t)
1163                                        (asynchronous? #f)
1164                                        (asynchronous-error (undefined-value)))
1165        ;
1166        (let ([log #f])
1167                ;
1168                (set! args
1169                      (fixup-extended-lambda-list-rest '(#:source #:level #:echos #:alternates #:open?)
1170                                                       args))
1171                ;
1172                (if (%log-argument? str)
1173        (begin
1174          (set! log str)
1175          (if (null? args)
1176              (log$error 'log-string "missing message")
1177              (set! str (pop! args)) ) )
1178        (set! log (default-logbook)) )
1179                ;
1180                (check-log-argument log 'log-string)
1181                (set! log (resolve-log-object log))
1182                ;
1183                (check-optional check-source-argument source 'log-string)
1184                (check-source-for-log log
1185                        (resolve-source-object
1186                                (optional-value source (default-logbook-source)))
1187                        'log-string)
1188                ;
1189                (check-optional check-level-argument level 'log-string)
1190                (when (logable-level? log
1191                                                (resolve-level-object
1192                                                        (optional-value level (default-logbook-level))))
1193                        ;
1194                        (check-string str 'log-string)
1195                        (check-optional check-procedure asynchronous-error 'log-string)
1196                        (check-optional check-logs-argument echos 'log-string)
1197                        (check-optional check-logs-argument alternates 'log-string)
1198                        (check-boolean open? 'log-string)
1199                        (check-boolean asynchronous? 'log-string)
1200                        ;
1201                        (%log-string log
1202                                str
1203                                (most-specific-echos log
1204                                        (resolve-log-objects echos)
1205                                        (default-logbook-echos))
1206                                (most-specific-alternates log
1207                                        (resolve-log-objects alternates)
1208                                        (default-logbook-alternates))
1209                                open?
1210                                (optional-log-value log asynchronous?)
1211                                (optional-log-value log asynchronous-error)) ) ) )
1212
1213;;
1214
1215(define (*log-message log msg entry indent source level fields echos alternates open? asynchronous? asynchronous-error loc)
1216        ;
1217        (check-log-argument log loc)
1218        (set! log (resolve-log-object log))
1219        ;
1220        (check-optional check-entry-argument entry loc)
1221        (set! entry
1222                (resolve-entry-object (optional-value entry (%log-entry log))))
1223        ;
1224        (check-optional check-level-argument level loc)
1225        (set! level
1226                (resolve-level-object
1227                        (most-specific-level entry level (default-logbook-level))))
1228        ;
1229        (when (logable-level? log level)
1230                ;
1231                (check-optional check-source-argument source loc)
1232                (set! source
1233                        (resolve-source-object
1234                                (optional-value source (default-logbook-source))))
1235                (check-source-for-log log source loc)
1236                ;
1237                (check-string msg loc)
1238                (check-indent indent loc)
1239                (check-boolean open? loc)
1240                (check-optional check-fields fields loc)
1241                (check-optional check-logs-argument echos loc)
1242                (check-optional check-logs-argument alternates loc)
1243                (check-optional check-boolean asynchronous? loc)
1244                (check-optional check-procedure asynchronous-error loc)
1245                ;
1246                (%log-string log
1247                        (*make-log-string log entry indent source level fields (list msg) loc)
1248                        (most-specific-echos log
1249                                (resolve-log-objects echos)
1250                                (default-logbook-echos))
1251                        (most-specific-alternates log
1252                                (resolve-log-objects alternates)
1253                                (default-logbook-alternates))
1254                        open?
1255                        (optional-log-value log asynchronous?)
1256                        (optional-log-value log asynchronous-error)) ) )
1257
1258;; (log-message (msg|log) (msg|null) ...)
1259
1260(define (log-message msg #!rest fields
1261                                        #!key
1262                                        (entry (undefined-value))
1263                                        (indent 0)
1264                                        (source (undefined-value))
1265                                        (level (undefined-value))
1266                                        (echos (undefined-value))
1267                                        (alternates (undefined-value))
1268                                        (open? #t)
1269                                        (asynchronous? (undefined-value))
1270                                        (asynchronous-error (undefined-value)))
1271        ;
1272        (let ([log #f])
1273                ;
1274                (set! fields
1275                      (fixup-extended-lambda-list-rest
1276                       '(#:entry #:indent #:source #:level #:echos #:alternates
1277                         #:open? #:asynchronous? #:asynchronous-error)
1278                       fields))
1279                ;
1280                (if (%log-argument? msg)
1281        (begin
1282          (set! log msg)
1283          (if (null? fields)
1284            (log$error 'log-message "missing message")
1285            (set! msg (pop! fields)) ) )
1286        (set! log (default-logbook)) )
1287                ;
1288                (*log-message log
1289                        msg
1290                        entry
1291                        indent source level
1292                        (if (null? fields) (undefined-value) fields)
1293                        echos alternates
1294                        open?
1295                        asynchronous? asynchronous-error
1296                        'log-message) ) )
1297
1298;; (log-format (format-string|log) (format-string|null) ...)
1299
1300(define (log-format format-string #!rest args
1301                                        #!key
1302                                        (entry (undefined-value))
1303                                        (indent 0)
1304                                        (fields (undefined-value))
1305                                        (source (undefined-value))
1306                                        (level (undefined-value))
1307                                        (echos (undefined-value))
1308                                        (alternates (undefined-value))
1309                                        (open? #t)
1310                                        (asynchronous? (undefined-value))
1311                                        (asynchronous-error (undefined-value)))
1312        ;
1313        (let ([log #f])
1314                ;
1315                (set! args
1316                      (fixup-extended-lambda-list-rest
1317                       '(#:entry #:indent #:fields #:source #:level #:echos #:alternates
1318                         #:open? #:asynchronous? #:asynchronous-error)
1319                       args))
1320                ;
1321                (if (%log-argument? format-string)
1322        (begin
1323          (set! log format-string)
1324          (if (null? args)
1325            (log$error 'log-format "missing format-string")
1326            (set! format-string (pop! args)) ) )
1327        (set! log (default-logbook)) )
1328                ;
1329                (check-string format-string 'log-format)
1330                ;
1331                (*log-message log
1332                        (apply (current-logbook-format-procedure) #f format-string args)
1333                        entry
1334                        indent source level fields
1335                        echos alternates
1336                        open?
1337                        asynchronous? asynchronous-error
1338                        'log-format) ) )
1339
1340;;; Logbook Open/Close
1341
1342(define (open-logbook log)
1343        (check-log-argument log 'open-logbook)
1344        (force-open-log (resolve-log-object log) 'open-logbook) )
1345
1346(define (close-logbook log)
1347        (check-log-argument log 'close-logbook)
1348        (force-close-log (resolve-log-object log) 'close-logbook) )
1349
1350;;; Logger Initial State Build
1351
1352(define (initialize-logger)
1353        ;
1354        (log$empty-catalog)
1355        (logbook-uri-scheme-handler 'mailto log$mail-uri-handler)
1356        ;
1357        (new-logbook-source 'all "")
1358        (default-logbook-sources '(all))
1359        (default-logbook-source 'all)
1360        ;
1361        (new-logbook-level 'off most-positive-fixnum "")
1362        (new-logbook-level 'fatal 90 "FATAL")
1363        (new-logbook-level 'emergency 80 "EMERGENCY")
1364        (new-logbook-level 'alert 70 "ALERT")
1365        (new-logbook-level 'critical 60 "CRITICAL")
1366        (new-logbook-level 'error 50 "ERROR")
1367        (new-logbook-level 'warning 40 "WARNING")
1368        (new-logbook-level 'notice 30 "NOTICE")
1369        (new-logbook-level 'info 20 "INFO")
1370        (new-logbook-level 'debug 10 "DEBUG")
1371        (new-logbook-level 'trace 0 "TRACE")
1372        (new-logbook-level 'all most-negative-fixnum "")
1373        (default-logbook-level 'all)
1374        (default-entry-level 'all)
1375        ;
1376        (new-logbook-field 'source void)
1377        (new-logbook-field 'level void)
1378        (new-logbook-field 'pid pid-field)
1379        (new-logbook-field 'hostname hostname-field)
1380        (new-logbook-field 'timestamp timestamp-field)
1381        (default-logbook-fields '(timestamp " " (? source " ") (? level " ")))
1382        (default-entry-fields (default-logbook-fields))
1383        ;
1384        (new-logbook-entry 'message)
1385        (default-logbook-entries '(message))
1386        (default-logbook-entry 'message)
1387        ;
1388        (new-logbook 'message)
1389        (default-logbook 'message)
1390        ;
1391        (create-console-log)
1392        #+unix (create-system-log)
1393        (create-error-log)
1394        ;
1395        (asynchronous-logger-start!)
1396        (on-exit
1397                (lambda ()
1398                        (let/cc return
1399                                (with-exception-handler
1400                                        (lambda (exp)
1401                                                (return))
1402                                        (lambda ()
1403                                                (asynchronous-logger-stop!) ) ) ) ) ) )
1404
1405(initialize-logger)
Note: See TracBrowser for help on using the repository browser.