Changeset 9139 in project for release/3/logging


Ignore:
Timestamp:
03/01/08 15:57:54 (12 years ago)
Author:
Kon Lovett
Message:

Fix for e-mail uri query processing. Cosmetic chgs.

Location:
release/3/logging
Files:
16 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/3/logging/tags/1.1.0/logging-catalogs.scm

    r9025 r9139  
    11;;;; logging-catalogs.scm
    22;;;; Kon Lovett, Sep '06
    3 
    4 (use srfi-18 utils)
    5 (use lookup-table synch miscmacros)
    6 (use logging-errors)
    73
    84(eval-when (compile)
     
    3127                log$log-catalog-for-each) ) )
    3228
     29(use srfi-18 utils)
     30(use lookup-table synch miscmacros)
     31(use logging-errors)
     32
    3333;;; Catalog Support
    3434
     
    3838        (%let/synch ([dict cat])
    3939                (if (symbol? key)
    40                         (values
    41                           key
    42                           (dict-ref dict key))
    43                         (values
    44                                 (dict-search dict
    45                                         (lambda (id value)
    46                                                 (and (equal? key value)
    47                                                            (begin (set! key id) #t))))
    48                                 key) ) ) )
     40        (values
     41          key
     42          (dict-ref dict key))
     43        (values
     44          (dict-search dict
     45            (lambda (id value)
     46              (and (equal? key value)
     47                   (begin (set! key id) #t))))
     48          key) ) ) )
    4949
    5050(define (log$catalog-value cat key)
     
    6565        (let/synch ([dict cat])
    6666                (if (dict-ref dict key)
    67                         (log$error loc "identifier in use" key)
    68                         (dict-set! dict key value)) ) )
     67        (log$error loc "identifier in use" key)
     68        (dict-set! dict key value)) ) )
    6969
    7070(define (log$catalog-set! cat key value loc)
  • release/3/logging/tags/1.1.0/logging-eggdoc.scm

    r9026 r9139  
    594594                        )
    595595
    596                         #;(examples ,examples)
     596                        #;
     597                        (examples ,examples)
    597598                )
    598599
     
    601602                        (p "Poor documentation.")
    602603
    603                         (p "Too many options (?) with complicated argument processing.")
     604                        (p "Many options with complicated argument processing.")
    604605
    605606                        (p "No Windows support for syslog.")
     
    613614
    614615                (history
     616                        (version "1.1.0" "Fix for \"make-log-mail-string\" uri query processing.")
    615617                        (version "1.0.0" "Use of \"fixup-extended-lambda-list-rest\".")
    616618                        (version "0.301" "Dependency requirements update")
  • release/3/logging/tags/1.1.0/logging-errors.scm

    r9025 r9139  
    11;;;; logging-errors.scm
    22;;;; Kon Lovett, Sep '06
    3 
    4 (use srfi-1 #;srfi-12)
    53
    64(eval-when (compile)
     
    1412                log$errors) ) )
    1513
     14(use srfi-1 srfi-12)
     15
    1616;;; Exceptions
    1717
    1818;;
    1919
     20(define (log$make-exn-condition loc msg . args)
     21  (make-property-condition 'exn 'message msg 'location loc 'arguments args) )
     22
    2023(define (log$make-error-condition loc msg . args)
    2124        (make-composite-condition
    22                 (if (null? args)
    23                         (make-property-condition 'exn 'message msg 'location loc)
    24                         (make-property-condition 'exn 'message msg 'location loc 'arguments args) )
     25                (apply log$make-exn-condition loc msg args)
    2526                (make-property-condition 'logger)) )
    2627
    2728(define (log$make-errors-condition loc msg errors . args)
    2829        (make-composite-condition
    29                 (if (null? args)
    30                         (make-property-condition 'exn 'message msg 'location loc)
    31                         (make-property-condition 'exn 'message msg 'location loc 'arguments args) )
     30                (apply log$make-exn-condition loc msg args)
    3231                (make-property-condition 'logger 'errors errors)) )
    3332
     
    4645                (lambda args
    4746                        (if (null? args)
    48                                 errors
    49                                 (set! errors (alist-cons (car args) (cadr args) errors))) ) ) )
     47          errors
     48          (set! errors (alist-cons (car args) (cadr args) errors))) ) ) )
  • release/3/logging/tags/1.1.0/logging-files.scm

    r9025 r9139  
    11;;;; logging-files.scm
    22;;;; 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)
    73
    84(eval-when (compile)
     
    2117                        logbook-catalog-merge
    2218                        logbook-catalog-store) ) )
     19
     20(use srfi-1 srfi-18 utils posix)
     21(use lookup-table synch misc-extn-record misc-extn-posix miscmacros z3 s11n)
     22(use logging-catalogs logging-errors logging-objects logging-operations logging-parameters)
    2323
    2424;;;
     
    161161        (check-string pathname 'logbook-catalog-merge)
    162162        (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) ) )
     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) )
    173173
    174174(define (logbook-catalog-store #!optional (pathname (default-logbook-catalog)))
  • release/3/logging/tags/1.1.0/logging-objects.scm

    r9025 r9139  
    11;;;; logging-objects.scm
    22;;;; Kon Lovett, Sep '06
    3 
    4 (use srfi-18)
    5 (use lookup-table synch)
    6 (use logging-errors logging-catalogs)
    73
    84(eval-when (compile)
     
    3026                        logbook-delete!) ) )
    3127
     28(use srfi-18)
     29(use lookup-table synch)
     30(use logging-errors logging-catalogs)
     31
    3232;;;
    3333
  • release/3/logging/tags/1.1.0/logging-operations.scm

    r9025 r9139  
    11;;;; logging-operations.scm
    22;;;; 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)
    73
    84(eval-when (compile)
     
    1511                        log$log-force-open
    1612                        log$log-force-close) ) )
     13
     14(use srfi-1 srfi-13 srfi-18 utils posix extras)
     15(use lookup-table synch misc-extn-list miscmacros uri)
     16(use logging-errors logging-parameters)
    1717
    1818;;;
     
    122122                                 [proc (logbook-uri-scheme-handler scheme)])
    123123                (if proc
    124                         (proc log str errors)
    125                         (begin
    126                                 (errors 'log-to-uri (list "unrecognized uri scheme" scheme))
    127                                 #f) ) ) )
     124        (proc log str errors)
     125        (begin
     126          (errors 'log-to-uri (list "unrecognized uri scheme" scheme))
     127          #f) ) ) )
    128128
    129129(define-inline (log$log-write log str errors)
    130130        (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) ) ) ) )
     131      (log$log-to-uri log str errors)
     132      (let ([port (%log-port log)])
     133        (and port
     134          (%log-write log port str errors) ) ) ) )
    135135
    136136;;; Open multiple logs
     
    140140(define (open-log-or-alternate log alternates open? errors)
    141141        (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 ) ) )
     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 ) ) )
    150150
    151151;; Returns (log ...) or ()
  • release/3/logging/tags/1.1.0/logging-parameters.scm

    r9025 r9139  
    11;;;; logging-parameters.scm
    22;;;; Kon Lovett, Sep '06
    3 
    4 (use utils extras posix)
    5 (use miscmacros)
    63
    74(eval-when (compile)
     
    3330                        default-logbook-catalog) ) )
    3431
     32(use utils extras posix)
     33(use miscmacros)
     34
    3535;;;
    3636
    3737(include "logging-constants")
    38 
    3938(include "logging-record-types")
    40 
    4139(include "logging-argument-checking")
    4240
     
    4644        (lambda (obj)
    4745                (if (list? obj)
    48                         (for-each pred obj)
    49                         (pred obj)) ) )
    50 
    51 ;;;
    52 
    53 #;(define-parameter default-file-permissions (bitwise-ior perm/irusr perm/iwusr perm/irgrp perm/iroth)
     46        (for-each pred obj)
     47        (pred obj)) ) )
     48
     49;;;
     50
     51#;
     52(define-parameter default-file-permissions
     53  (bitwise-ior perm/irusr perm/iwusr perm/irgrp perm/iroth)
    5454        (lambda (x)
    5555                (if (fixnum? x)
    56                         x
    57                         (default-file-permissions)) ) )
    58 
    59 (define-parameter default-asynchronous-error (lambda (exp) exp)
     56        x
     57        (begin
     58                (warning 'default-file-permissions "invalid parameter value" x)
     59                (default-file-permissions) ) ) ) )
     60
     61(define-parameter default-asynchronous-error
     62  (lambda (exp) exp)
    6063        (lambda (x)
    6164                (if (procedure? x)
    62                         x
    63                         (default-asynchronous-error)) ) )
    64 
    65 (define-parameter current-logbook-format-procedure (lambda (dest fstr . args) (apply format fstr args))
     65        x
     66        (begin
     67                (warning 'default-asynchronous-error "invalid parameter value" x)
     68                (default-asynchronous-error) ) ) ) )
     69
     70(define-parameter current-logbook-format-procedure
     71  (lambda (dest fstr . args) (apply format fstr args))
    6672        (lambda (x)
    6773                (if (procedure? x)
    68                         x
    69                         (current-logbook-format-procedure)) ) )
    70 
    71 (define-parameter default-logbook 'none
     74        x
     75        (begin
     76                (warning 'current-logbook-format-procedure "invalid parameter value" x)
     77          (current-logbook-format-procedure) ) ) ) )
     78
     79(define-parameter default-logbook
     80  'none
    7281        (lambda (x)
    7382                (if (%log-argument? x)
    74                         x
    75                         (default-logbook)) ) )
    76 
    77 (define-parameter current-logbook-indent-amount DEFAULT-INDENT-AMOUNT
     83        x
     84        (begin
     85                (warning 'default-logbook "invalid parameter value" x)
     86                (default-logbook) ) ) ) )
     87
     88(define-parameter current-logbook-indent-amount
     89  DEFAULT-INDENT-AMOUNT
    7890        (lambda (x)
    7991                (if (and (fixnum? x) (<= 0 x) (< x MAXIMUM-INDENT-AMOUNT))
    80                         x
    81                         (current-logbook-indent-amount)) ) )
    82 
    83 (define-parameter default-logbook-directory #f
     92        x
     93        (begin
     94                (warning 'current-logbook-indent-amount "invalid parameter value" x)
     95          (current-logbook-indent-amount) ) ) ) )
     96
     97(define-parameter default-logbook-directory
     98  #f
    8499        (lambda (x)
    85100                (if (%directory-argument? x)
    86                         x
    87                         (default-logbook-directory)) ) )
    88 
    89 (define-parameter default-logbook-extension "log"
     101        x
     102        (begin
     103                (warning 'default-logbook-directory "invalid parameter value" x)
     104                (default-logbook-directory) ) ) ) )
     105
     106(define-parameter default-logbook-extension
     107  "log"
    90108        (lambda (x)
    91109                (if (%extension-argument? x)
    92                         x
    93                         (default-logbook-extension)) ) )
    94 
    95 (define-parameter default-logbook-entries '()
     110        x
     111        (begin
     112                (warning 'default-logbook-extension "invalid parameter value" x)
     113                (default-logbook-extension) ) ) ) )
     114
     115(define-parameter default-logbook-entries
     116  '()
    96117        (let ([pred (atom-or-list-of %entry-argument?)])
    97118                (lambda (x)
    98119                        (if (pred x)
    99                                 x
    100                                 (default-logbook-entries)) ) ) )
    101 
    102 (define-parameter default-logbook-sources '()
     120          x
     121          (begin
     122                (warning 'default-logbook-entries "invalid parameter value" x)
     123                (default-logbook-entries) ) ) ) ) )
     124
     125(define-parameter default-logbook-sources
     126  '()
    103127        (let ([pred (atom-or-list-of %source-argument?)])
    104128                (lambda (x)
    105129                        (if (pred x)
    106                                 x
    107                                 (default-logbook-sources)) ) ) )
    108 
    109 (define-parameter default-logbook-fields '()
     130          x
     131          (begin
     132                (warning 'default-logbook-sources "invalid parameter value" x)
     133                (default-logbook-sources) ) ) ) ) )
     134
     135(define-parameter default-logbook-fields
     136  '()
    110137        (let ([pred (atom-or-list-of field-value?)])
    111138                (lambda (x)
    112139                        (if (pred x)
    113                                 x
    114                                 (default-logbook-fields)) ) ) )
    115 
    116 (define-parameter default-logbook-entry 'none
     140          x
     141          (begin
     142                (warning 'default-logbook-fields "invalid parameter value" x)
     143                (default-logbook-fields) ) ) ) ) )
     144
     145(define-parameter default-logbook-entry
     146  'none
    117147        (lambda (x)
    118148                (if (%entry-argument? x)
    119                         x
    120                         (default-logbook-entry)) ) )
    121 
    122 (define-parameter default-logbook-source ""
     149        x
     150        (begin
     151                (warning 'default-logbook-entry "invalid parameter value" x)
     152                (default-logbook-entry) ) ) ) )
     153
     154(define-parameter default-logbook-source
     155  ""
    123156        (lambda (x)
    124157                (if (%source-argument? x)
    125                         x
    126                         (default-logbook-source)) ) )
    127 
    128 (define-parameter default-logbook-level ""
     158        x
     159        (begin
     160                (warning 'default-logbook-source "invalid parameter value" x)
     161                (default-logbook-source) ) ) ) )
     162
     163(define-parameter default-logbook-level
     164  ""
    129165        (lambda (x)
    130166                (if (%level-argument? x)
    131                         x
    132                         (default-logbook-level)) ) )
    133 
    134 (define-parameter default-logbook-echos '()
     167        x
     168        (begin
     169                (warning 'default-logbook-level "invalid parameter value" x)
     170                (default-logbook-level) ) ) ) )
     171
     172(define-parameter default-logbook-echos
     173  '()
    135174        (let ([pred (atom-or-list-of %log-argument?)])
    136175                (lambda (x)
    137176                        (if (pred x)
    138                                 x
    139                                 (default-logbook-echos)) ) ) )
    140 
    141 (define-parameter default-logbook-alternates '()
     177          x
     178          (begin
     179                (warning 'default-logbook-echos "invalid parameter value" x)
     180                (default-logbook-echos) ) ) ) ) )
     181
     182(define-parameter default-logbook-alternates
     183  '()
    142184        (let ([pred (atom-or-list-of %log-argument?)])
    143185                (lambda (x)
    144186                        (if (pred x)
    145                                 x
    146                                 (default-logbook-alternates)) ) ) )
    147 
    148 (define-parameter default-entry-level ""
     187          x
     188          (begin
     189                (warning 'default-logbook-alternates "invalid parameter value" x)
     190                (default-logbook-alternates) ) ) ) ) )
     191
     192(define-parameter default-entry-level
     193  ""
    149194        (lambda (x)
    150195                (if (%level-argument? x)
    151                         x
    152                         (default-entry-level)) ) )
    153 
    154 (define-parameter default-entry-fields '()
     196        x
     197        (begin
     198                (warning 'default-entry-level "invalid parameter value" x)
     199                (default-entry-level) ) ) ) )
     200
     201(define-parameter default-entry-fields
     202  '()
    155203        (let ([pred (atom-or-list-of field-value?)])
    156204                (lambda (x)
    157205                        (if (pred x)
    158                                 x
    159                                 (default-entry-fields)) ) ) )
     206          x
     207          (begin
     208                (warning 'default-entry-fields "invalid parameter value" x)
     209                (default-entry-fields) ) ) ) ) )
    160210
    161211(define-parameter default-logbook-catalog
     
    163213        (lambda (x)
    164214                (if (string? x)
    165                         x
    166                         (default-logbook-catalog)) ) )
    167 
    168 (define-parameter default-mail-authority (list #f "" DEFAULT-SMTP-PORT)
    169         (lambda (x)
    170                 (if (and (list? x) (eqv? 3 (length x)))
    171                         x
    172                         (default-mail-authority) ) ) )
     215        x
     216        (begin
     217                (warning 'default-logbook-catalog "invalid parameter value" x)
     218                (default-logbook-catalog) ) ) ) )
     219
     220(define-parameter default-mail-authority
     221  (list #f "" DEFAULT-SMTP-PORT)
     222        (lambda (x)
     223                (if (and (list? x) (= 3 (length x)))
     224        x
     225        (begin
     226                (warning 'default-mail-authority "invalid parameter value" x)
     227                (default-mail-authority) ) ) ) )
     228
     229;;;
    173230
    174231(define logbook-uri-scheme-handler
     
    176233                (lambda (scheme #!optional proc)
    177234                        (if proc
    178                                 (set! handlers (alist-update! scheme proc handlers eq?))
    179                                 (alist-ref scheme handlers eq?) ) ) ) )
     235          (set! handlers (alist-update! scheme proc handlers eq?))
     236          (alist-ref scheme handlers eq?) ) ) ) )
  • release/3/logging/tags/1.1.0/logging.scm

    r9026 r9139  
    9090/*static int syslog_facility = LOG_USER;*/
    9191
    92 static
    93 void syslog_set_level (int level/*, int source*/)
     92static void
     93syslog_set_level( int level/*, int source*/ )
    9494{
    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         }
     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    }
    106106}
    107107
    108 static
    109 int syslog_str (const char *str)
     108static int
     109syslog_str( const char *str )
    110110{
    111         syslog (syslog_level | LOG_USER, "%s", str);
    112         return 1;
     111    syslog( syslog_level | LOG_USER, "%s", str );
     112    return 1;
    113113}
    114114<#
     
    117117
    118118(include "logging-constants")
    119 
    120119(include "logging-record-types")
    121 
    122120(include "logging-argument-checking")
    123121
     
    246244                                         [scheme (uri-scheme obj)])
    247245                        (when scheme
    248                                 (switch scheme
    249                                         ['file
     246                                (case scheme
     247                                        [(file)
    250248                                                (%log-pathname-set! log (uri-encode-path obj))]
    251249                                        [else
     
    262260                                        operations
    263261                                        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)])
     262        (let ([log
     263          (%make-log id
     264            mutable?
     265            pathname
     266            (delete-duplicates sources eq?)
     267            entry level
     268            (delete-duplicates echos eq?)
     269            (delete-duplicates alternates eq?)
     270            keep-open?
     271            immediate-open?
     272            operations
     273            asynchronous?
     274            asynchronous-error)])
    278275                (%log-uri-or-pathname-set! log pathname)
    279276                (%log-session-open-set! log #f)
     
    357354(define (logable-level? log level)
    358355        (and (level<=? (%log-level log) level)
    359                 (let ([mask (%log-level-mask log)])
    360                         (or (null? mask) (member level mask)))) )
     356       (let ([mask (%log-level-mask log)])
     357         (or (null? mask)
     358             (member level mask)))) )
    361359
    362360;;; Argument Checking
     
    392390                (log$error loc "invalid procedure" obj)) )
    393391
    394 #;(define (check-directory obj loc)
     392#;
     393(define (check-directory obj loc)
    395394        (unless (%directory-argument? obj)
    396395                (log$error loc "invalid directory name" obj)) )
    397396
    398 #;(define (check-filename obj loc)
     397#;
     398(define (check-filename obj loc)
    399399        (unless (%filename-argument? obj)
    400400                (log$error loc "invalid filename" obj)) )
    401401
    402 #;(define (check-extension obj loc)
     402#;
     403(define (check-extension obj loc)
    403404        (unless (%extension-argument? obj)
    404405                (log$error loc "invalid pathname extension" obj)) )
     
    525526
    526527(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))] ) )
     528        (cond [(pair? obj)        (map proc obj)]
     529        [(list? obj)        obj]
     530        [(undefined? obj)   obj]
     531        [else               (list (proc obj))] ) )
    531532
    532533;;
     
    562563                (lambda ()
    563564                        (unless pidstr
    564                                 (set! pidstr (conc #\[ (number->string (current-process-id)) #\])) )
     565                                (set! pidstr (string-append "[" (number->string (current-process-id)) "]")) )
    565566                        pidstr ) ) )
    566567
     
    709710        (set! entry (resolve-entry-object entry))
    710711        ;
    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)])
     712        (let ([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)])
    723723                (when (%log-immediate-open? log)
    724724                        (force-open-log log 'make-logbook) )
     
    755755        (check-optional check-procedure asynchronous-error 'clone-logbook)
    756756        ;
    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)])
     757        (let ([clone
     758          (clone-log (resolve-log-object log) id
     759            mutable?
     760            pathname
     761            (resolve-source-objects sources)
     762            (resolve-entry-object entry)
     763            (resolve-level-object level)
     764            (resolve-log-objects echos) (resolve-log-objects alternates)
     765            keep-open? immediate-open?
     766            operations
     767            asynchronous? asynchronous-error)])
    769768                (when (%log-immediate-open? clone)
    770769                        (force-open-log clone 'clone-logbook))
     
    845844                                (let (
    846845                                                [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])])
     846                                                        (case (%level-id level)
     847                                                                [(emergency) 0]
     848                                                                [(alert)      1]
     849                                                                [(critical)  2]
     850                                                                [(error)      3]
     851                                                                [(warning)    4]
     852                                                                [(notice)    5]
     853                                                                [(info)      6]
     854                                                                [(debug)      7]
     855                                                                [else         6])])
    857856                                        ($ syslog_set_level (int ilvl))
    858857                                        (fields->strings source level fields)))) ) )
     
    885884        (check-log-argument log 'set-logbook-level!)
    886885        (check-level-argument level 'set-logbook-level!)
    887         (%log-level-set!
    888                 (resolve-log-object log)
    889                 (resolve-level-object level)) )
     886        (%log-level-set! (resolve-log-object log) (resolve-level-object level)) )
    890887
    891888(define (logbook-level-mask log)
     
    896893        (check-log-argument log 'set-logbook-level-mask!)
    897894        (check-levels-argument levels 'set-logbook-level-mask!)
    898         (%log-level-mask-set!
    899                 (resolve-log-object log)
    900                 (resolve-level-objects levels)) )
     895        (%log-level-mask-set! (resolve-log-object log) (resolve-level-objects levels)) )
    901896
    902897;;; Message Construction
    903898
    904899(define indent->string
    905         (let (
    906                         [spcstr (make-string (* MAXIMUM-INDENT MAXIMUM-INDENT-AMOUNT) #\space)])
     900        (let ([spcstr (make-string (* MAXIMUM-INDENT MAXIMUM-INDENT-AMOUNT) #\space)])
    907901                (lambda (indent)
    908902                        (if (positive? indent)
    909           (let ([len (* indent (current-logbook-indent-amount))])
    910             (substring/shared spcstr 0 len) )
     903          (substring/shared spcstr 0 (* indent (current-logbook-indent-amount)))
    911904          "") ) ) )
    912905
     
    928921            (fld->str (%field-value field))]
    929922          [(symbol? field)
    930             (switch field
    931               ['source (source->string source)]
    932               ['level (level->string level)]
     923            (case field
     924              [(source)
     925                (source->string source)]
     926              [(level)
     927                (level->string level)]
    933928              [else
    934929                (let ([fld (log$catalog-ref log$field-catalog->field field)])
    935930                  (if fld
    936                     (fld->str fld)
    937                     (symbol->string field) ) )] )]
     931                      (fld->str fld)
     932                      (symbol->string field) ) )] )]
    938933          [(procedure? field)
    939934            (field)]
    940935          [(length>1? field)
    941             (switch (car field)
    942               ['quote
     936            (case (car field)
     937              [(quote)
    943938                (symbol->string (cadr field))]
    944               ['?
    945                 (let ([args (cdr field)])
    946                   (let ([str (fld->str (car args))])
    947                     (if (string-null? str)
     939              [(?)
     940                (let* ([args (cdr field)]
     941                       [str (fld->str (car args))])
     942                  (if (string-null? str)
    948943                      str
    949                       (apply string-append/shared str (map fld->str (cdr args))) ) ) )]
     944                      (apply string-append/shared str (map fld->str (cdr args))) ) ) ]
    950945              [else
    951946                (->string field)] )]
     
    954949
    955950(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))] ) )
     951        (cond [(null? fields)
     952                ""]
     953        [(pair? fields)
     954          (map (cut field->string source level <>) fields)]
     955        [else
     956          (list (field->string source level fields))] ) )
    959957
    960958;; (%make-log-string 0 "" "" '() str ...)
     
    10391037                      (let ([key (car pair)]
    10401038                            [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)])))
     1039                        (cond [(string=? "body" key)
     1040                                (set! body
     1041                                      (cons (string-append (cdr pair) mail-line-break) body))
     1042                                ""]
     1043                              [(string=? "from" key)
     1044                                (set! from (cdr pair))
     1045                                ""]
     1046                              [(string=? "subject" key)
     1047                                (set! subject (cdr pair))
     1048                                ""]
     1049                              [else
     1050                                (make-mail-header-line key val)])))
    10561051                    (or al '()))])
    10571052            (values
     
    10781073                    host (get-host-name)
    10791074                    #f (or port DEFAULT-SMTP-PORT))])
    1080               (receive [tos from cntnts] (make-log-mail-string log str)
     1075              (let-values ([(tos from cntnts) (make-log-mail-string log str)])
    10811076                (with-output-to-port (apply smtp:open smtpc from tos)
    10821077                  (lambda () (display cntnts)))
     
    10991094                        (let ([action (car todo)]
    11001095                                                [args (cdr todo)])
    1101                                 (switch action
    1102                                         ['quit
     1096                                (case action
     1097                                        [(quit)
    11031098                                                (void)]
    1104                                         ['write
     1099                                        [(write)
    11051100                                                (let ([errors (log$make-errors)])
    11061101                                                        (let* ([log-args (cdr args)]
     
    11121107                                                (asynchronous-logger)]
    11131108                                        [else
    1114                                                 (log$error (thread-name (current-thread))
    1115                                                         "unknown operation" todo)]) ) ) )
     1109                                                (log$error (thread-name (current-thread)) "unknown operation" todo)]) ) ) )
    11161110
    11171111        (set! asynchronous-logger-start!
     
    11441138        (if asynchronous?
    11451139      (asynchronous-logger-send!
    1146         (list 'write
    1147           (optional-value asynchronous-error
    1148             (default-asynchronous-error))
     1140        (list
     1141          'write
     1142          (optional-value asynchronous-error (default-asynchronous-error))
    11491143          log str echos alternates open?))
    11501144      (let ([errors (log$make-errors)])
     
    12021196                                str
    12031197                                (most-specific-echos log
    1204                                         (resolve-log-objects echos)
    1205                                         (default-logbook-echos))
     1198                             (resolve-log-objects echos)
     1199                             (default-logbook-echos))
    12061200                                (most-specific-alternates log
    1207                                         (resolve-log-objects alternates)
    1208                                         (default-logbook-alternates))
     1201                                  (resolve-log-objects alternates)
     1202                                  (default-logbook-alternates))
    12091203                                open?
    12101204                                (optional-log-value log asynchronous?)
     
    12471241                        (*make-log-string log entry indent source level fields (list msg) loc)
    12481242                        (most-specific-echos log
    1249                                 (resolve-log-objects echos)
    1250                                 (default-logbook-echos))
     1243                           (resolve-log-objects echos)
     1244                           (default-logbook-echos))
    12511245                        (most-specific-alternates log
    1252                                 (resolve-log-objects alternates)
    1253                                 (default-logbook-alternates))
     1246                                (resolve-log-objects alternates)
     1247                                (default-logbook-alternates))
    12541248                        open?
    12551249                        (optional-log-value log asynchronous?)
     
    12821276          (set! log msg)
    12831277          (if (null? fields)
    1284             (log$error 'log-message "missing message")
    1285             (set! msg (pop! fields)) ) )
     1278              (log$error 'log-message "missing message")
     1279              (set! msg (pop! fields)) ) )
    12861280        (set! log (default-logbook)) )
    12871281                ;
     
    13591353        (default-logbook-source 'all)
    13601354        ;
    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 "")
     1355        (new-logbook-level 'off         most-positive-fixnum "")
     1356        (new-logbook-level 'fatal       90                    "FATAL")
     1357        (new-logbook-level 'emergency   80                    "EMERGENCY")
     1358        (new-logbook-level 'alert       70                    "ALERT")
     1359        (new-logbook-level 'critical    60                    "CRITICAL")
     1360        (new-logbook-level 'error       50                    "ERROR")
     1361        (new-logbook-level 'warning     40                    "WARNING")
     1362        (new-logbook-level 'notice      30                    "NOTICE")
     1363        (new-logbook-level 'info        20                    "INFO")
     1364        (new-logbook-level 'debug       10                    "DEBUG")
     1365        (new-logbook-level 'trace       0                    "TRACE")
     1366        (new-logbook-level 'all         most-negative-fixnum "")
    13731367        (default-logbook-level 'all)
    13741368        (default-entry-level 'all)
     
    14031397                                                (asynchronous-logger-stop!) ) ) ) ) ) )
    14041398
     1399;;; Module Initialize
     1400
    14051401(initialize-logger)
  • release/3/logging/trunk/logging-catalogs.scm

    r9025 r9139  
    11;;;; logging-catalogs.scm
    22;;;; Kon Lovett, Sep '06
    3 
    4 (use srfi-18 utils)
    5 (use lookup-table synch miscmacros)
    6 (use logging-errors)
    73
    84(eval-when (compile)
     
    3127                log$log-catalog-for-each) ) )
    3228
     29(use srfi-18 utils)
     30(use lookup-table synch miscmacros)
     31(use logging-errors)
     32
    3333;;; Catalog Support
    3434
     
    3838        (%let/synch ([dict cat])
    3939                (if (symbol? key)
    40                         (values
    41                           key
    42                           (dict-ref dict key))
    43                         (values
    44                                 (dict-search dict
    45                                         (lambda (id value)
    46                                                 (and (equal? key value)
    47                                                            (begin (set! key id) #t))))
    48                                 key) ) ) )
     40        (values
     41          key
     42          (dict-ref dict key))
     43        (values
     44          (dict-search dict
     45            (lambda (id value)
     46              (and (equal? key value)
     47                   (begin (set! key id) #t))))
     48          key) ) ) )
    4949
    5050(define (log$catalog-value cat key)
     
    6565        (let/synch ([dict cat])
    6666                (if (dict-ref dict key)
    67                         (log$error loc "identifier in use" key)
    68                         (dict-set! dict key value)) ) )
     67        (log$error loc "identifier in use" key)
     68        (dict-set! dict key value)) ) )
    6969
    7070(define (log$catalog-set! cat key value loc)
  • release/3/logging/trunk/logging-eggdoc.scm

    r9026 r9139  
    594594                        )
    595595
    596                         #;(examples ,examples)
     596                        #;
     597                        (examples ,examples)
    597598                )
    598599
     
    601602                        (p "Poor documentation.")
    602603
    603                         (p "Too many options (?) with complicated argument processing.")
     604                        (p "Many options with complicated argument processing.")
    604605
    605606                        (p "No Windows support for syslog.")
     
    613614
    614615                (history
     616                        (version "1.1.0" "Fix for \"make-log-mail-string\" uri query processing.")
    615617                        (version "1.0.0" "Use of \"fixup-extended-lambda-list-rest\".")
    616618                        (version "0.301" "Dependency requirements update")
  • release/3/logging/trunk/logging-errors.scm

    r9025 r9139  
    11;;;; logging-errors.scm
    22;;;; Kon Lovett, Sep '06
    3 
    4 (use srfi-1 #;srfi-12)
    53
    64(eval-when (compile)
     
    1412                log$errors) ) )
    1513
     14(use srfi-1 srfi-12)
     15
    1616;;; Exceptions
    1717
    1818;;
    1919
     20(define (log$make-exn-condition loc msg . args)
     21  (make-property-condition 'exn 'message msg 'location loc 'arguments args) )
     22
    2023(define (log$make-error-condition loc msg . args)
    2124        (make-composite-condition
    22                 (if (null? args)
    23                         (make-property-condition 'exn 'message msg 'location loc)
    24                         (make-property-condition 'exn 'message msg 'location loc 'arguments args) )
     25                (apply log$make-exn-condition loc msg args)
    2526                (make-property-condition 'logger)) )
    2627
    2728(define (log$make-errors-condition loc msg errors . args)
    2829        (make-composite-condition
    29                 (if (null? args)
    30                         (make-property-condition 'exn 'message msg 'location loc)
    31                         (make-property-condition 'exn 'message msg 'location loc 'arguments args) )
     30                (apply log$make-exn-condition loc msg args)
    3231                (make-property-condition 'logger 'errors errors)) )
    3332
     
    4645                (lambda args
    4746                        (if (null? args)
    48                                 errors
    49                                 (set! errors (alist-cons (car args) (cadr args) errors))) ) ) )
     47          errors
     48          (set! errors (alist-cons (car args) (cadr args) errors))) ) ) )
  • release/3/logging/trunk/logging-files.scm

    r9025 r9139  
    11;;;; logging-files.scm
    22;;;; 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)
    73
    84(eval-when (compile)
     
    2117                        logbook-catalog-merge
    2218                        logbook-catalog-store) ) )
     19
     20(use srfi-1 srfi-18 utils posix)
     21(use lookup-table synch misc-extn-record misc-extn-posix miscmacros z3 s11n)
     22(use logging-catalogs logging-errors logging-objects logging-operations logging-parameters)
    2323
    2424;;;
     
    161161        (check-string pathname 'logbook-catalog-merge)
    162162        (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) ) )
     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) )
    173173
    174174(define (logbook-catalog-store #!optional (pathname (default-logbook-catalog)))
  • release/3/logging/trunk/logging-objects.scm

    r9025 r9139  
    11;;;; logging-objects.scm
    22;;;; Kon Lovett, Sep '06
    3 
    4 (use srfi-18)
    5 (use lookup-table synch)
    6 (use logging-errors logging-catalogs)
    73
    84(eval-when (compile)
     
    3026                        logbook-delete!) ) )
    3127
     28(use srfi-18)
     29(use lookup-table synch)
     30(use logging-errors logging-catalogs)
     31
    3232;;;
    3333
  • release/3/logging/trunk/logging-operations.scm

    r9025 r9139  
    11;;;; logging-operations.scm
    22;;;; 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)
    73
    84(eval-when (compile)
     
    1511                        log$log-force-open
    1612                        log$log-force-close) ) )
     13
     14(use srfi-1 srfi-13 srfi-18 utils posix extras)
     15(use lookup-table synch misc-extn-list miscmacros uri)
     16(use logging-errors logging-parameters)
    1717
    1818;;;
     
    122122                                 [proc (logbook-uri-scheme-handler scheme)])
    123123                (if proc
    124                         (proc log str errors)
    125                         (begin
    126                                 (errors 'log-to-uri (list "unrecognized uri scheme" scheme))
    127                                 #f) ) ) )
     124        (proc log str errors)
     125        (begin
     126          (errors 'log-to-uri (list "unrecognized uri scheme" scheme))
     127          #f) ) ) )
    128128
    129129(define-inline (log$log-write log str errors)
    130130        (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) ) ) ) )
     131      (log$log-to-uri log str errors)
     132      (let ([port (%log-port log)])
     133        (and port
     134          (%log-write log port str errors) ) ) ) )
    135135
    136136;;; Open multiple logs
     
    140140(define (open-log-or-alternate log alternates open? errors)
    141141        (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 ) ) )
     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 ) ) )
    150150
    151151;; Returns (log ...) or ()
  • release/3/logging/trunk/logging-parameters.scm

    r9025 r9139  
    11;;;; logging-parameters.scm
    22;;;; Kon Lovett, Sep '06
    3 
    4 (use utils extras posix)
    5 (use miscmacros)
    63
    74(eval-when (compile)
     
    3330                        default-logbook-catalog) ) )
    3431
     32(use utils extras posix)
     33(use miscmacros)
     34
    3535;;;
    3636
    3737(include "logging-constants")
    38 
    3938(include "logging-record-types")
    40 
    4139(include "logging-argument-checking")
    4240
     
    4644        (lambda (obj)
    4745                (if (list? obj)
    48                         (for-each pred obj)
    49                         (pred obj)) ) )
    50 
    51 ;;;
    52 
    53 #;(define-parameter default-file-permissions (bitwise-ior perm/irusr perm/iwusr perm/irgrp perm/iroth)
     46        (for-each pred obj)
     47        (pred obj)) ) )
     48
     49;;;
     50
     51#;
     52(define-parameter default-file-permissions
     53  (bitwise-ior perm/irusr perm/iwusr perm/irgrp perm/iroth)
    5454        (lambda (x)
    5555                (if (fixnum? x)
    56                         x
    57                         (default-file-permissions)) ) )
    58 
    59 (define-parameter default-asynchronous-error (lambda (exp) exp)
     56        x
     57        (begin
     58                (warning 'default-file-permissions "invalid parameter value" x)
     59                (default-file-permissions) ) ) ) )
     60
     61(define-parameter default-asynchronous-error
     62  (lambda (exp) exp)
    6063        (lambda (x)
    6164                (if (procedure? x)
    62                         x
    63                         (default-asynchronous-error)) ) )
    64 
    65 (define-parameter current-logbook-format-procedure (lambda (dest fstr . args) (apply format fstr args))
     65        x
     66        (begin
     67                (warning 'default-asynchronous-error "invalid parameter value" x)
     68                (default-asynchronous-error) ) ) ) )
     69
     70(define-parameter current-logbook-format-procedure
     71  (lambda (dest fstr . args) (apply format fstr args))
    6672        (lambda (x)
    6773                (if (procedure? x)
    68                         x
    69                         (current-logbook-format-procedure)) ) )
    70 
    71 (define-parameter default-logbook 'none
     74        x
     75        (begin
     76                (warning 'current-logbook-format-procedure "invalid parameter value" x)
     77          (current-logbook-format-procedure) ) ) ) )
     78
     79(define-parameter default-logbook
     80  'none
    7281        (lambda (x)
    7382                (if (%log-argument? x)
    74                         x
    75                         (default-logbook)) ) )
    76 
    77 (define-parameter current-logbook-indent-amount DEFAULT-INDENT-AMOUNT
     83        x
     84        (begin
     85                (warning 'default-logbook "invalid parameter value" x)
     86                (default-logbook) ) ) ) )
     87
     88(define-parameter current-logbook-indent-amount
     89  DEFAULT-INDENT-AMOUNT
    7890        (lambda (x)
    7991                (if (and (fixnum? x) (<= 0 x) (< x MAXIMUM-INDENT-AMOUNT))
    80                         x
    81                         (current-logbook-indent-amount)) ) )
    82 
    83 (define-parameter default-logbook-directory #f
     92        x
     93        (begin
     94                (warning 'current-logbook-indent-amount "invalid parameter value" x)
     95          (current-logbook-indent-amount) ) ) ) )
     96
     97(define-parameter default-logbook-directory
     98  #f
    8499        (lambda (x)
    85100                (if (%directory-argument? x)
    86                         x
    87                         (default-logbook-directory)) ) )
    88 
    89 (define-parameter default-logbook-extension "log"
     101        x
     102        (begin
     103                (warning 'default-logbook-directory "invalid parameter value" x)
     104                (default-logbook-directory) ) ) ) )
     105
     106(define-parameter default-logbook-extension
     107  "log"
    90108        (lambda (x)
    91109                (if (%extension-argument? x)
    92                         x
    93                         (default-logbook-extension)) ) )
    94 
    95 (define-parameter default-logbook-entries '()
     110        x
     111        (begin
     112                (warning 'default-logbook-extension "invalid parameter value" x)
     113                (default-logbook-extension) ) ) ) )
     114
     115(define-parameter default-logbook-entries
     116  '()
    96117        (let ([pred (atom-or-list-of %entry-argument?)])
    97118                (lambda (x)
    98119                        (if (pred x)
    99                                 x
    100                                 (default-logbook-entries)) ) ) )
    101 
    102 (define-parameter default-logbook-sources '()
     120          x
     121          (begin
     122                (warning 'default-logbook-entries "invalid parameter value" x)
     123                (default-logbook-entries) ) ) ) ) )
     124
     125(define-parameter default-logbook-sources
     126  '()
    103127        (let ([pred (atom-or-list-of %source-argument?)])
    104128                (lambda (x)
    105129                        (if (pred x)
    106                                 x
    107                                 (default-logbook-sources)) ) ) )
    108 
    109 (define-parameter default-logbook-fields '()
     130          x
     131          (begin
     132                (warning 'default-logbook-sources "invalid parameter value" x)
     133                (default-logbook-sources) ) ) ) ) )
     134
     135(define-parameter default-logbook-fields
     136  '()
    110137        (let ([pred (atom-or-list-of field-value?)])
    111138                (lambda (x)
    112139                        (if (pred x)
    113                                 x
    114                                 (default-logbook-fields)) ) ) )
    115 
    116 (define-parameter default-logbook-entry 'none
     140          x
     141          (begin
     142                (warning 'default-logbook-fields "invalid parameter value" x)
     143                (default-logbook-fields) ) ) ) ) )
     144
     145(define-parameter default-logbook-entry
     146  'none
    117147        (lambda (x)
    118148                (if (%entry-argument? x)
    119                         x
    120                         (default-logbook-entry)) ) )
    121 
    122 (define-parameter default-logbook-source ""
     149        x
     150        (begin
     151                (warning 'default-logbook-entry "invalid parameter value" x)
     152                (default-logbook-entry) ) ) ) )
     153
     154(define-parameter default-logbook-source
     155  ""
    123156        (lambda (x)
    124157                (if (%source-argument? x)
    125                         x
    126                         (default-logbook-source)) ) )
    127 
    128 (define-parameter default-logbook-level ""
     158        x
     159        (begin
     160                (warning 'default-logbook-source "invalid parameter value" x)
     161                (default-logbook-source) ) ) ) )
     162
     163(define-parameter default-logbook-level
     164  ""
    129165        (lambda (x)
    130166                (if (%level-argument? x)
    131                         x
    132                         (default-logbook-level)) ) )
    133 
    134 (define-parameter default-logbook-echos '()
     167        x
     168        (begin
     169                (warning 'default-logbook-level "invalid parameter value" x)
     170                (default-logbook-level) ) ) ) )
     171
     172(define-parameter default-logbook-echos
     173  '()
    135174        (let ([pred (atom-or-list-of %log-argument?)])
    136175                (lambda (x)
    137176                        (if (pred x)
    138                                 x
    139                                 (default-logbook-echos)) ) ) )
    140 
    141 (define-parameter default-logbook-alternates '()
     177          x
     178          (begin
     179                (warning 'default-logbook-echos "invalid parameter value" x)
     180                (default-logbook-echos) ) ) ) ) )
     181
     182(define-parameter default-logbook-alternates
     183  '()
    142184        (let ([pred (atom-or-list-of %log-argument?)])
    143185                (lambda (x)
    144186                        (if (pred x)
    145                                 x
    146                                 (default-logbook-alternates)) ) ) )
    147 
    148 (define-parameter default-entry-level ""
     187          x
     188          (begin
     189                (warning 'default-logbook-alternates "invalid parameter value" x)
     190                (default-logbook-alternates) ) ) ) ) )
     191
     192(define-parameter default-entry-level
     193  ""
    149194        (lambda (x)
    150195                (if (%level-argument? x)
    151                         x
    152                         (default-entry-level)) ) )
    153 
    154 (define-parameter default-entry-fields '()
     196        x
     197        (begin
     198                (warning 'default-entry-level "invalid parameter value" x)
     199                (default-entry-level) ) ) ) )
     200
     201(define-parameter default-entry-fields
     202  '()
    155203        (let ([pred (atom-or-list-of field-value?)])
    156204                (lambda (x)
    157205                        (if (pred x)
    158                                 x
    159                                 (default-entry-fields)) ) ) )
     206          x
     207          (begin
     208                (warning 'default-entry-fields "invalid parameter value" x)
     209                (default-entry-fields) ) ) ) ) )
    160210
    161211(define-parameter default-logbook-catalog
     
    163213        (lambda (x)
    164214                (if (string? x)
    165                         x
    166                         (default-logbook-catalog)) ) )
    167 
    168 (define-parameter default-mail-authority (list #f "" DEFAULT-SMTP-PORT)
    169         (lambda (x)
    170                 (if (and (list? x) (eqv? 3 (length x)))
    171                         x
    172                         (default-mail-authority) ) ) )
     215        x
     216        (begin
     217                (warning 'default-logbook-catalog "invalid parameter value" x)
     218                (default-logbook-catalog) ) ) ) )
     219
     220(define-parameter default-mail-authority
     221  (list #f "" DEFAULT-SMTP-PORT)
     222        (lambda (x)
     223                (if (and (list? x) (= 3 (length x)))
     224        x
     225        (begin
     226                (warning 'default-mail-authority "invalid parameter value" x)
     227                (default-mail-authority) ) ) ) )
     228
     229;;;
    173230
    174231(define logbook-uri-scheme-handler
     
    176233                (lambda (scheme #!optional proc)
    177234                        (if proc
    178                                 (set! handlers (alist-update! scheme proc handlers eq?))
    179                                 (alist-ref scheme handlers eq?) ) ) ) )
     235          (set! handlers (alist-update! scheme proc handlers eq?))
     236          (alist-ref scheme handlers eq?) ) ) ) )
  • release/3/logging/trunk/logging.scm

    r9026 r9139  
    9090/*static int syslog_facility = LOG_USER;*/
    9191
    92 static
    93 void syslog_set_level (int level/*, int source*/)
     92static void
     93syslog_set_level( int level/*, int source*/ )
    9494{
    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         }
     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    }
    106106}
    107107
    108 static
    109 int syslog_str (const char *str)
     108static int
     109syslog_str( const char *str )
    110110{
    111         syslog (syslog_level | LOG_USER, "%s", str);
    112         return 1;
     111    syslog( syslog_level | LOG_USER, "%s", str );
     112    return 1;
    113113}
    114114<#
     
    117117
    118118(include "logging-constants")
    119 
    120119(include "logging-record-types")
    121 
    122120(include "logging-argument-checking")
    123121
     
    246244                                         [scheme (uri-scheme obj)])
    247245                        (when scheme
    248                                 (switch scheme
    249                                         ['file
     246                                (case scheme
     247                                        [(file)
    250248                                                (%log-pathname-set! log (uri-encode-path obj))]
    251249                                        [else
     
    262260                                        operations
    263261                                        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)])
     262        (let ([log
     263          (%make-log id
     264            mutable?
     265            pathname
     266            (delete-duplicates sources eq?)
     267            entry level
     268            (delete-duplicates echos eq?)
     269            (delete-duplicates alternates eq?)
     270            keep-open?
     271            immediate-open?
     272            operations
     273            asynchronous?
     274            asynchronous-error)])
    278275                (%log-uri-or-pathname-set! log pathname)
    279276                (%log-session-open-set! log #f)
     
    357354(define (logable-level? log level)
    358355        (and (level<=? (%log-level log) level)
    359                 (let ([mask (%log-level-mask log)])
    360                         (or (null? mask) (member level mask)))) )
     356       (let ([mask (%log-level-mask log)])
     357         (or (null? mask)
     358             (member level mask)))) )
    361359
    362360;;; Argument Checking
     
    392390                (log$error loc "invalid procedure" obj)) )
    393391
    394 #;(define (check-directory obj loc)
     392#;
     393(define (check-directory obj loc)
    395394        (unless (%directory-argument? obj)
    396395                (log$error loc "invalid directory name" obj)) )
    397396
    398 #;(define (check-filename obj loc)
     397#;
     398(define (check-filename obj loc)
    399399        (unless (%filename-argument? obj)
    400400                (log$error loc "invalid filename" obj)) )
    401401
    402 #;(define (check-extension obj loc)
     402#;
     403(define (check-extension obj loc)
    403404        (unless (%extension-argument? obj)
    404405                (log$error loc "invalid pathname extension" obj)) )
     
    525526
    526527(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))] ) )
     528        (cond [(pair? obj)        (map proc obj)]
     529        [(list? obj)        obj]
     530        [(undefined? obj)   obj]
     531        [else               (list (proc obj))] ) )
    531532
    532533;;
     
    562563                (lambda ()
    563564                        (unless pidstr
    564                                 (set! pidstr (conc #\[ (number->string (current-process-id)) #\])) )
     565                                (set! pidstr (string-append "[" (number->string (current-process-id)) "]")) )
    565566                        pidstr ) ) )
    566567
     
    709710        (set! entry (resolve-entry-object entry))
    710711        ;
    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)])
     712        (let ([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)])
    723723                (when (%log-immediate-open? log)
    724724                        (force-open-log log 'make-logbook) )
     
    755755        (check-optional check-procedure asynchronous-error 'clone-logbook)
    756756        ;
    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)])
     757        (let ([clone
     758          (clone-log (resolve-log-object log) id
     759            mutable?
     760            pathname
     761            (resolve-source-objects sources)
     762            (resolve-entry-object entry)
     763            (resolve-level-object level)
     764            (resolve-log-objects echos) (resolve-log-objects alternates)
     765            keep-open? immediate-open?
     766            operations
     767            asynchronous? asynchronous-error)])
    769768                (when (%log-immediate-open? clone)
    770769                        (force-open-log clone 'clone-logbook))
     
    845844                                (let (
    846845                                                [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])])
     846                                                        (case (%level-id level)
     847                                                                [(emergency) 0]
     848                                                                [(alert)      1]
     849                                                                [(critical)  2]
     850                                                                [(error)      3]
     851                                                                [(warning)    4]
     852                                                                [(notice)    5]
     853                                                                [(info)      6]
     854                                                                [(debug)      7]
     855                                                                [else         6])])
    857856                                        ($ syslog_set_level (int ilvl))
    858857                                        (fields->strings source level fields)))) ) )
     
    885884        (check-log-argument log 'set-logbook-level!)
    886885        (check-level-argument level 'set-logbook-level!)
    887         (%log-level-set!
    888                 (resolve-log-object log)
    889                 (resolve-level-object level)) )
     886        (%log-level-set! (resolve-log-object log) (resolve-level-object level)) )
    890887
    891888(define (logbook-level-mask log)
     
    896893        (check-log-argument log 'set-logbook-level-mask!)
    897894        (check-levels-argument levels 'set-logbook-level-mask!)
    898         (%log-level-mask-set!
    899                 (resolve-log-object log)
    900                 (resolve-level-objects levels)) )
     895        (%log-level-mask-set! (resolve-log-object log) (resolve-level-objects levels)) )
    901896
    902897;;; Message Construction
    903898
    904899(define indent->string
    905         (let (
    906                         [spcstr (make-string (* MAXIMUM-INDENT MAXIMUM-INDENT-AMOUNT) #\space)])
     900        (let ([spcstr (make-string (* MAXIMUM-INDENT MAXIMUM-INDENT-AMOUNT) #\space)])
    907901                (lambda (indent)
    908902                        (if (positive? indent)
    909           (let ([len (* indent (current-logbook-indent-amount))])
    910             (substring/shared spcstr 0 len) )
     903          (substring/shared spcstr 0 (* indent (current-logbook-indent-amount)))
    911904          "") ) ) )
    912905
     
    928921            (fld->str (%field-value field))]
    929922          [(symbol? field)
    930             (switch field
    931               ['source (source->string source)]
    932               ['level (level->string level)]
     923            (case field
     924              [(source)
     925                (source->string source)]
     926              [(level)
     927                (level->string level)]
    933928              [else
    934929                (let ([fld (log$catalog-ref log$field-catalog->field field)])
    935930                  (if fld
    936                     (fld->str fld)
    937                     (symbol->string field) ) )] )]
     931                      (fld->str fld)
     932                      (symbol->string field) ) )] )]
    938933          [(procedure? field)
    939934            (field)]
    940935          [(length>1? field)
    941             (switch (car field)
    942               ['quote
     936            (case (car field)
     937              [(quote)
    943938                (symbol->string (cadr field))]
    944               ['?
    945                 (let ([args (cdr field)])
    946                   (let ([str (fld->str (car args))])
    947                     (if (string-null? str)
     939              [(?)
     940                (let* ([args (cdr field)]
     941                       [str (fld->str (car args))])
     942                  (if (string-null? str)
    948943                      str
    949                       (apply string-append/shared str (map fld->str (cdr args))) ) ) )]
     944                      (apply string-append/shared str (map fld->str (cdr args))) ) ) ]
    950945              [else
    951946                (->string field)] )]
     
    954949
    955950(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))] ) )
     951        (cond [(null? fields)
     952                ""]
     953        [(pair? fields)
     954          (map (cut field->string source level <>) fields)]
     955        [else
     956          (list (field->string source level fields))] ) )
    959957
    960958;; (%make-log-string 0 "" "" '() str ...)
     
    10391037                      (let ([key (car pair)]
    10401038                            [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)])))
     1039                        (cond [(string=? "body" key)
     1040                                (set! body
     1041                                      (cons (string-append (cdr pair) mail-line-break) body))
     1042                                ""]
     1043                              [(string=? "from" key)
     1044                                (set! from (cdr pair))
     1045                                ""]
     1046                              [(string=? "subject" key)
     1047                                (set! subject (cdr pair))
     1048                                ""]
     1049                              [else
     1050                                (make-mail-header-line key val)])))
    10561051                    (or al '()))])
    10571052            (values
     
    10781073                    host (get-host-name)
    10791074                    #f (or port DEFAULT-SMTP-PORT))])
    1080               (receive [tos from cntnts] (make-log-mail-string log str)
     1075              (let-values ([(tos from cntnts) (make-log-mail-string log str)])
    10811076                (with-output-to-port (apply smtp:open smtpc from tos)
    10821077                  (lambda () (display cntnts)))
     
    10991094                        (let ([action (car todo)]
    11001095                                                [args (cdr todo)])
    1101                                 (switch action
    1102                                         ['quit
     1096                                (case action
     1097                                        [(quit)
    11031098                                                (void)]
    1104                                         ['write
     1099                                        [(write)
    11051100                                                (let ([errors (log$make-errors)])
    11061101                                                        (let* ([log-args (cdr args)]
     
    11121107                                                (asynchronous-logger)]
    11131108                                        [else
    1114                                                 (log$error (thread-name (current-thread))
    1115                                                         "unknown operation" todo)]) ) ) )
     1109                                                (log$error (thread-name (current-thread)) "unknown operation" todo)]) ) ) )
    11161110
    11171111        (set! asynchronous-logger-start!
     
    11441138        (if asynchronous?
    11451139      (asynchronous-logger-send!
    1146         (list 'write
    1147           (optional-value asynchronous-error
    1148             (default-asynchronous-error))
     1140        (list
     1141          'write
     1142          (optional-value asynchronous-error (default-asynchronous-error))
    11491143          log str echos alternates open?))
    11501144      (let ([errors (log$make-errors)])
     
    12021196                                str
    12031197                                (most-specific-echos log
    1204                                         (resolve-log-objects echos)
    1205                                         (default-logbook-echos))
     1198                             (resolve-log-objects echos)
     1199                             (default-logbook-echos))
    12061200                                (most-specific-alternates log
    1207                                         (resolve-log-objects alternates)
    1208                                         (default-logbook-alternates))
     1201                                  (resolve-log-objects alternates)
     1202                                  (default-logbook-alternates))
    12091203                                open?
    12101204                                (optional-log-value log asynchronous?)
     
    12471241                        (*make-log-string log entry indent source level fields (list msg) loc)
    12481242                        (most-specific-echos log
    1249                                 (resolve-log-objects echos)
    1250                                 (default-logbook-echos))
     1243                           (resolve-log-objects echos)
     1244                           (default-logbook-echos))
    12511245                        (most-specific-alternates log
    1252                                 (resolve-log-objects alternates)
    1253                                 (default-logbook-alternates))
     1246                                (resolve-log-objects alternates)
     1247                                (default-logbook-alternates))
    12541248                        open?
    12551249                        (optional-log-value log asynchronous?)
     
    12821276          (set! log msg)
    12831277          (if (null? fields)
    1284             (log$error 'log-message "missing message")
    1285             (set! msg (pop! fields)) ) )
     1278              (log$error 'log-message "missing message")
     1279              (set! msg (pop! fields)) ) )
    12861280        (set! log (default-logbook)) )
    12871281                ;
     
    13591353        (default-logbook-source 'all)
    13601354        ;
    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 "")
     1355        (new-logbook-level 'off         most-positive-fixnum "")
     1356        (new-logbook-level 'fatal       90                    "FATAL")
     1357        (new-logbook-level 'emergency   80                    "EMERGENCY")
     1358        (new-logbook-level 'alert       70                    "ALERT")
     1359        (new-logbook-level 'critical    60                    "CRITICAL")
     1360        (new-logbook-level 'error       50                    "ERROR")
     1361        (new-logbook-level 'warning     40                    "WARNING")
     1362        (new-logbook-level 'notice      30                    "NOTICE")
     1363        (new-logbook-level 'info        20                    "INFO")
     1364        (new-logbook-level 'debug       10                    "DEBUG")
     1365        (new-logbook-level 'trace       0                    "TRACE")
     1366        (new-logbook-level 'all         most-negative-fixnum "")
    13731367        (default-logbook-level 'all)
    13741368        (default-entry-level 'all)
     
    14031397                                                (asynchronous-logger-stop!) ) ) ) ) ) )
    14041398
     1399;;; Module Initialize
     1400
    14051401(initialize-logger)
Note: See TracChangeset for help on using the changeset viewer.