Changeset 9026 in project for release/3/logging


Ignore:
Timestamp:
02/26/08 15:39:26 (12 years ago)
Author:
Kon Lovett
Message:

Rel 1.0.0 (no real changes)

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

Legend:

Unmodified
Added
Removed
  • release/3/logging/tags/1.0.0/logging-eggdoc.scm

    r9025 r9026  
    3535                (description (p "Logging Facility"))
    3636                (author (url "mailto:klovett@pacbell.net" "Kon Lovett"))
    37                 (history
    38                         (version "0.301" "Dependency requirements update")
    39                         (version "0.3" "Log level mask")
    40                         (version "0.2" "Some URI support")
    41                         (version "0.1" "Initial release"))
    4237                (usage)
    4338                (download "logging.egg")
     
    617612                )
    618613
     614                (history
     615                        (version "1.0.0" "Use of \"fixup-extended-lambda-list-rest\".")
     616                        (version "0.301" "Dependency requirements update")
     617                        (version "0.3" "Log level mask")
     618                        (version "0.2" "Some URI support")
     619                        (version "0.1" "Initial release"))
     620
    619621                (section "License" (pre ,license))
    620622        )
  • release/3/logging/tags/1.0.0/logging.html

    r9025 r9026  
    156156<h3>Author</h3><a href="mailto:klovett@pacbell.net">Kon Lovett</a></div>
    157157<div class="section">
    158 <h3>Version</h3>
    159 <ul>
    160 <li>0.3 Log level mask</li>
    161 <li>0.2 Some URI support</li>
    162 <li>0.1 Initial release</li></ul></div>
    163 <div class="section">
    164158<h3>Usage</h3><tt>(require-extension logging)</tt></div>
    165159<div class="section">
     
    630624<p>No abstractions for distributed logging.</p>
    631625<p>Incomplete testing.</p></div>
     626<div class="section">
     627<h3>Version</h3>
     628<ul>
     629<li>1.0.0 Use of &quot;fixup-extended-lambda-list-rest&quot;.</li>
     630<li>0.301 Dependency requirements update</li>
     631<li>0.3 Log level mask</li>
     632<li>0.2 Some URI support</li>
     633<li>0.1 Initial release</li></ul></div>
    632634<div class="section">
    633635<h3>License</h3>
  • release/3/logging/tags/1.0.0/logging.scm

    r9025 r9026  
    3333;;
    3434;;              - Grouping all catalog dictionaries in a single record type.
    35 
    36 (use srfi-1 srfi-13 srfi-18 utils posix extras regex)
    37 (use lookup-table synch
    38      misc-extn-list misc-extn-posix
    39      miscmacros mailbox mathh-int uri smtp)
    40 (use logging-errors logging-catalogs logging-operations logging-parameters)
    4135
    4236(eval-when (compile)
     
    7872                        log-string
    7973                        log-message
    80                         log-format) ) )
     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)
    8181
    8282;;;
     
    366366(define (check-atom-or-list-of proc obj loc)
    367367        (if (list? obj)
    368                 (for-each (cut proc <> loc) obj)
    369                 (proc obj loc)) )
     368      (for-each (cut proc <> loc) obj)
     369      (proc obj loc)) )
    370370
    371371(define (check-optional proc obj loc)
     
    484484(define (most-specific-entry-item entry ref item default-item)
    485485        (if (or (not item) (undefined? item))
    486                 (or
    487                         (and (not (undefined? entry))
    488                                 (%synch/entry entry (ref entry)))
    489                         default-item)
    490                 item ) )
     486      (or (and (not (undefined? entry))
     487               (%synch/entry entry (ref entry)))
     488          default-item)
     489      item ) )
    491490
    492491(define (most-specific-log log ref logs default-logs)
     
    522521(define (resolve-object cat obj)
    523522        (if (symbol? obj)
    524                 (log$catalog-value cat obj)
    525                 obj ) )
     523      (log$catalog-value cat obj)
     524      obj ) )
    526525
    527526(define (resolve-objects proc obj)
    528         (cond
    529                 [(pair? obj) (map proc obj)]
    530                 [(list? obj) obj]
    531                 [(undefined? obj) obj]
    532                 [else (list (proc obj))] ) )
     527        (cond [(pair? obj) (map proc obj)]
     528        [(list? obj) obj]
     529        [(undefined? obj) obj]
     530        [else (list (proc obj))] ) )
    533531
    534532;;
     
    580578                                                                 [itmstr (number->string itm)])
    581579                                                (if (< itm 10)
    582                                                         (string-append/shared prefix itmstr)
    583                                                         itmstr ) ) )])
     580                (string-append/shared prefix itmstr)
     581                itmstr ) ) )])
    584582                (string-append/shared
    585583                        monstr " " (number->string (vector-ref timvec 3))
     
    639637                                        (level (default-entry-level)))
    640638        ;
    641         (set! fields (filter-rest-argument! fields
    642                 '(#:level #:indent #:mutable?)))
     639        (set! fields
     640              (fixup-extended-lambda-list-rest '(#:level #:indent #:mutable?)
     641                                               fields))
    643642        ;
    644643        (check-symbol id 'make-logbook-entry)
     
    659658                                        (level (undefined-value)))
    660659        ;
    661         (set! fields (filter-rest-argument! fields
    662                 '(#:level #:indent #:mutable?)))
     660        (set! fields
     661              (fixup-extended-lambda-list-rest '(#:level #:indent #:mutable?)
     662                                               fields))
    663663        ;
    664664        (check-symbol id 'clone-logbook-entry)
     
    671671                indent
    672672                (resolve-level-object level)
    673                 (if (null? fields) (undefined-value) fields)) )
     673                (if (null? fields)
     674                    (undefined-value)
     675                    fields)) )
    674676
    675677(define (make-logbook id
     
    905907                (lambda (indent)
    906908                        (if (positive? indent)
    907                                 (let ([len (* indent (current-logbook-indent-amount))])
    908                                         (substring/shared spcstr 0 len) )
    909                                 "") ) ) )
     909          (let ([len (* indent (current-logbook-indent-amount))])
     910            (substring/shared spcstr 0 len) )
     911          "") ) ) )
    910912
    911913(define-inline (level->string level)
    912914        (if (%level? level)
    913                 (%level-name level)
    914                 level ) )
     915      (%level-name level)
     916      level ) )
    915917
    916918(define-inline (source->string source)
    917919        (if (%source? source)
    918                 (%source-name source)
    919                 source ) )
     920      (%source-name source)
     921      source ) )
    920922
    921923(define (field->string source level field)
    922924        (let fld->str ([field field])
    923                 (cond
    924                         [(string? field)
    925                                 field]
    926                         [(%field? field)
    927                                 (fld->str (%field-value field))]
    928                         [(symbol? field)
    929                                 (switch field
    930                                         ['source (source->string source)]
    931                                         ['level (level->string level)]
    932                                         [else
    933                                                 (let ([fld (log$catalog-ref log$field-catalog->field field)])
    934                                                         (if fld
    935                                                                 (fld->str fld)
    936                                                                 (symbol->string field) ) )] )]
    937                         [(procedure? field)
    938                                 (field)]
    939                         [(length>1? field)
    940                                 (switch (car field)
    941                                         ['quote
    942                                                 (symbol->string (cadr field))]
    943                                         ['?
    944                                                 (let ([args (cdr field)])
    945                                                         (let ([str (fld->str (car args))])
    946                                                                 (if (string-null? str)
    947                                                                         str
    948                                                                         (apply string-append/shared str (map fld->str (cdr args))) ) ) )]
    949                                         [else
    950                                                 (->string field)] )]
    951                         [else
    952                                 (->string 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)]) ) )
    953954
    954955(define (fields->strings source level fields)
    955         (cond
    956                 [(null? fields) ""]
    957                 [(pair? fields) (map (cut field->string source level <>) fields)]
    958                 [else (list (field->string 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))] ) )
    959959
    960960;; (%make-log-string 0 "" "" '() str ...)
     
    988988        (let ([log #f])
    989989                ;
    990                 (set! msgs (filter-rest-argument! msgs
    991                         '(#:indent #:entry #:source #:level #:fields)))
     990                (set! msgs
     991                      (fixup-extended-lambda-list-rest '(#:indent #:entry #:source #:level #:fields)
     992                                                       msgs))
    992993                        ;
    993994                        (if (and (pair? msgs) (%log-argument? (car msgs)))
    994                                 (begin
    995                                         (set! log (car msgs))
    996                                         (set! msgs (pop! msgs)) )
    997                                 (set! log (default-logbook)) )
     995          (begin
     996            (set! log (car msgs))
     997            (set! msgs (pop! msgs)) )
     998          (set! log (default-logbook)) )
    998999                ;
    9991000                (check-log-argument log 'log-string)
     
    10221023                                [mail-line-break "\r\n"])
    10231024                (if obj
    1024                         (let ([al (uri-query obj)]
    1025                                                 [from #f]
    1026                                                 [subject #f]
    1027                                                 [bdy '()]
    1028                                                 [make-mail-header-line
    1029                                                         (lambda (key val)
    1030                                                                 (string-append
    1031                                                                         (string-titlecase (->string key))
    1032                                                                         ": "
    1033                                                                         (->string val)
    1034                                                                         mail-line-break))])
    1035                                 (let ([hdr
    1036                                                                 (map
    1037                                                                         (lambda (pair)
    1038                                                                                 (let ([key (car pair)]
    1039                                                                                                         [val (cdr pair)])
    1040                                                                                         (case key
    1041                                                                                                 [("body")
    1042                                                                                                         (set! body
    1043                                                                                                           (cons
    1044                                                                                                             (string-append (cdr pair) mail-line-break)
    1045                                                                                                             body))
    1046                                                                                                         ""]
    1047                                                                                                 [("from")
    1048                                                                                                         (set! from (cdr pair))
    1049                                                                                                         ""]
    1050                                                                                                 [("subject")
    1051                                                                                                         (set! subject (cdr pair))
    1052                                                                                                         ""]
    1053                                                                                                 [else
    1054                                                                                                         (make-mail-header-line key val)])))
    1055                                                                         (or al '()))])
    1056                                         (values
    1057                                                 (string-split (uri-encode-path obj) ",")
    1058                                                 (or from (%log-id log))
    1059                                                 (string-append
    1060                                                         (list->string hdr)
    1061                                                         (make-mail-header-line "subject" (or subject str))
    1062                                                         mail-line-break
    1063                                                         (list->string bdy)
    1064                                                         (if subject "" (string-append str mail-line-break))) ) ) )
    1065                         (values '() "" "") ) ) )
     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 '() "" "") ) ) )
    10661067
    10671068(define (log$mail-uri-handler log str errors)
     
    10701071                (let ([auth (or (uri-authority obj) (default-mail-authority))])
    10711072                        (if auth
    1072                                 (let ([host (second auth)]
    1073                                       [port (third auth)])
    1074                                         (let (
    1075                                             [smtpc
    1076                                               (smtp:connect
    1077                                                 host (get-host-name)
    1078                                                 #f (or port DEFAULT-SMTP-PORT))])
    1079                                                 (receive [tos from cntnts] (make-log-mail-string log str)
    1080                                                         (with-output-to-port (apply smtp:open smtpc from tos)
    1081                                                                 (lambda () (display cntnts)))
    1082                                                         (smtp:disconnect smtpc)
    1083                                                         #t ) ) )
    1084                                 (begin
    1085                                         (errors 'mail-uri-handler "missing authority")
    1086                                         #f) ) ) ) )
     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) ) ) ) )
    10871088
    10881089;;; Asynchronous Logging
     
    11421143        ;
    11431144        (if asynchronous?
    1144                 (asynchronous-logger-send!
    1145                         (list 'write
    1146                                 (optional-value asynchronous-error
    1147                                         (default-asynchronous-error))
    1148                                 log str echos alternates open?))
    1149                 (let ([errors (log$make-errors)])
    1150                         (unless (log$log-string log errors str echos alternates open?)
    1151                                 (log$errors '%log-string "problem with log file" log (errors)) ) ) ) )
     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)) ) ) ) )
    11521153
    11531154;; (log-string (str|log) (str|null) ...)
     
    11651166        (let ([log #f])
    11661167                ;
    1167                 (set! args (filter-rest-argument! args
    1168                         '(#:source #:level #:echos #:alternates #:open?)))
     1168                (set! args
     1169                      (fixup-extended-lambda-list-rest '(#:source #:level #:echos #:alternates #:open?)
     1170                                                       args))
    11691171                ;
    11701172                (if (%log-argument? str)
    1171                         (begin
    1172                                 (set! log str)
    1173                                 (if (null? args)
    1174                                         (log$error 'log-string "missing message")
    1175                                         (set! str (pop! args)) ) )
    1176                         (set! log (default-logbook)) )
     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)) )
    11771179                ;
    11781180                (check-log-argument log 'log-string)
     
    12711273                ;
    12721274                (set! fields
    1273                         (filter-rest-argument! fields
    1274                                 '(#:entry #:indent #:source #:level #:echos #:alternates
    1275                                         #:open? #:asynchronous? #:asynchronous-error)))
     1275                      (fixup-extended-lambda-list-rest
     1276                       '(#:entry #:indent #:source #:level #:echos #:alternates
     1277                         #:open? #:asynchronous? #:asynchronous-error)
     1278                       fields))
    12761279                ;
    12771280                (if (%log-argument? msg)
    1278                         (begin
    1279                                 (set! log msg)
    1280                                 (if (null? fields)
    1281                                         (log$error 'log-message "missing message")
    1282                                         (set! msg (pop! fields)) ) )
    1283                         (set! log (default-logbook)) )
     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)) )
    12841287                ;
    12851288                (*log-message log
     
    13111314                ;
    13121315                (set! args
    1313                         (filter-rest-argument! args
    1314                                 '(#:entry #:indent #:fields #:source #:level #:echos #:alternates
    1315                                         #:open? #:asynchronous? #:asynchronous-error)))
     1316                      (fixup-extended-lambda-list-rest
     1317                       '(#:entry #:indent #:fields #:source #:level #:echos #:alternates
     1318                         #:open? #:asynchronous? #:asynchronous-error)
     1319                       args))
    13161320                ;
    13171321                (if (%log-argument? format-string)
    1318                         (begin
    1319                                 (set! log format-string)
    1320                                 (if (null? args)
    1321                                         (log$error 'log-format "missing format-string")
    1322                                         (set! format-string (pop! args)) ) )
    1323                         (set! log (default-logbook)) )
     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)) )
    13241328                ;
    13251329                (check-string format-string 'log-format)
  • release/3/logging/tags/1.0.0/logging.setup

    r9025 r9026  
    99  'mailbox                "1.1"
    1010  's11n                   "0.9"
    11   'mathh                  "1.9.2"
     11  'mathh                  "1.11"
    1212  'smtp                   "1.2"
    1313  'z3                     "1.36" )
  • release/3/logging/trunk/logging-eggdoc.scm

    r9025 r9026  
    3535                (description (p "Logging Facility"))
    3636                (author (url "mailto:klovett@pacbell.net" "Kon Lovett"))
    37                 (history
    38                         (version "0.301" "Dependency requirements update")
    39                         (version "0.3" "Log level mask")
    40                         (version "0.2" "Some URI support")
    41                         (version "0.1" "Initial release"))
    4237                (usage)
    4338                (download "logging.egg")
     
    617612                )
    618613
     614                (history
     615                        (version "1.0.0" "Use of \"fixup-extended-lambda-list-rest\".")
     616                        (version "0.301" "Dependency requirements update")
     617                        (version "0.3" "Log level mask")
     618                        (version "0.2" "Some URI support")
     619                        (version "0.1" "Initial release"))
     620
    619621                (section "License" (pre ,license))
    620622        )
  • release/3/logging/trunk/logging.html

    r9025 r9026  
    156156<h3>Author</h3><a href="mailto:klovett@pacbell.net">Kon Lovett</a></div>
    157157<div class="section">
    158 <h3>Version</h3>
    159 <ul>
    160 <li>0.3 Log level mask</li>
    161 <li>0.2 Some URI support</li>
    162 <li>0.1 Initial release</li></ul></div>
    163 <div class="section">
    164158<h3>Usage</h3><tt>(require-extension logging)</tt></div>
    165159<div class="section">
     
    630624<p>No abstractions for distributed logging.</p>
    631625<p>Incomplete testing.</p></div>
     626<div class="section">
     627<h3>Version</h3>
     628<ul>
     629<li>1.0.0 Use of &quot;fixup-extended-lambda-list-rest&quot;.</li>
     630<li>0.301 Dependency requirements update</li>
     631<li>0.3 Log level mask</li>
     632<li>0.2 Some URI support</li>
     633<li>0.1 Initial release</li></ul></div>
    632634<div class="section">
    633635<h3>License</h3>
  • release/3/logging/trunk/logging.scm

    r9025 r9026  
    3333;;
    3434;;              - Grouping all catalog dictionaries in a single record type.
    35 
    36 (use srfi-1 srfi-13 srfi-18 utils posix extras regex)
    37 (use lookup-table synch
    38      misc-extn-list misc-extn-posix
    39      miscmacros mailbox mathh-int uri smtp)
    40 (use logging-errors logging-catalogs logging-operations logging-parameters)
    4135
    4236(eval-when (compile)
     
    7872                        log-string
    7973                        log-message
    80                         log-format) ) )
     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)
    8181
    8282;;;
     
    366366(define (check-atom-or-list-of proc obj loc)
    367367        (if (list? obj)
    368                 (for-each (cut proc <> loc) obj)
    369                 (proc obj loc)) )
     368      (for-each (cut proc <> loc) obj)
     369      (proc obj loc)) )
    370370
    371371(define (check-optional proc obj loc)
     
    484484(define (most-specific-entry-item entry ref item default-item)
    485485        (if (or (not item) (undefined? item))
    486                 (or
    487                         (and (not (undefined? entry))
    488                                 (%synch/entry entry (ref entry)))
    489                         default-item)
    490                 item ) )
     486      (or (and (not (undefined? entry))
     487               (%synch/entry entry (ref entry)))
     488          default-item)
     489      item ) )
    491490
    492491(define (most-specific-log log ref logs default-logs)
     
    522521(define (resolve-object cat obj)
    523522        (if (symbol? obj)
    524                 (log$catalog-value cat obj)
    525                 obj ) )
     523      (log$catalog-value cat obj)
     524      obj ) )
    526525
    527526(define (resolve-objects proc obj)
    528         (cond
    529                 [(pair? obj) (map proc obj)]
    530                 [(list? obj) obj]
    531                 [(undefined? obj) obj]
    532                 [else (list (proc obj))] ) )
     527        (cond [(pair? obj) (map proc obj)]
     528        [(list? obj) obj]
     529        [(undefined? obj) obj]
     530        [else (list (proc obj))] ) )
    533531
    534532;;
     
    580578                                                                 [itmstr (number->string itm)])
    581579                                                (if (< itm 10)
    582                                                         (string-append/shared prefix itmstr)
    583                                                         itmstr ) ) )])
     580                (string-append/shared prefix itmstr)
     581                itmstr ) ) )])
    584582                (string-append/shared
    585583                        monstr " " (number->string (vector-ref timvec 3))
     
    639637                                        (level (default-entry-level)))
    640638        ;
    641         (set! fields (filter-rest-argument! fields
    642                 '(#:level #:indent #:mutable?)))
     639        (set! fields
     640              (fixup-extended-lambda-list-rest '(#:level #:indent #:mutable?)
     641                                               fields))
    643642        ;
    644643        (check-symbol id 'make-logbook-entry)
     
    659658                                        (level (undefined-value)))
    660659        ;
    661         (set! fields (filter-rest-argument! fields
    662                 '(#:level #:indent #:mutable?)))
     660        (set! fields
     661              (fixup-extended-lambda-list-rest '(#:level #:indent #:mutable?)
     662                                               fields))
    663663        ;
    664664        (check-symbol id 'clone-logbook-entry)
     
    671671                indent
    672672                (resolve-level-object level)
    673                 (if (null? fields) (undefined-value) fields)) )
     673                (if (null? fields)
     674                    (undefined-value)
     675                    fields)) )
    674676
    675677(define (make-logbook id
     
    905907                (lambda (indent)
    906908                        (if (positive? indent)
    907                                 (let ([len (* indent (current-logbook-indent-amount))])
    908                                         (substring/shared spcstr 0 len) )
    909                                 "") ) ) )
     909          (let ([len (* indent (current-logbook-indent-amount))])
     910            (substring/shared spcstr 0 len) )
     911          "") ) ) )
    910912
    911913(define-inline (level->string level)
    912914        (if (%level? level)
    913                 (%level-name level)
    914                 level ) )
     915      (%level-name level)
     916      level ) )
    915917
    916918(define-inline (source->string source)
    917919        (if (%source? source)
    918                 (%source-name source)
    919                 source ) )
     920      (%source-name source)
     921      source ) )
    920922
    921923(define (field->string source level field)
    922924        (let fld->str ([field field])
    923                 (cond
    924                         [(string? field)
    925                                 field]
    926                         [(%field? field)
    927                                 (fld->str (%field-value field))]
    928                         [(symbol? field)
    929                                 (switch field
    930                                         ['source (source->string source)]
    931                                         ['level (level->string level)]
    932                                         [else
    933                                                 (let ([fld (log$catalog-ref log$field-catalog->field field)])
    934                                                         (if fld
    935                                                                 (fld->str fld)
    936                                                                 (symbol->string field) ) )] )]
    937                         [(procedure? field)
    938                                 (field)]
    939                         [(length>1? field)
    940                                 (switch (car field)
    941                                         ['quote
    942                                                 (symbol->string (cadr field))]
    943                                         ['?
    944                                                 (let ([args (cdr field)])
    945                                                         (let ([str (fld->str (car args))])
    946                                                                 (if (string-null? str)
    947                                                                         str
    948                                                                         (apply string-append/shared str (map fld->str (cdr args))) ) ) )]
    949                                         [else
    950                                                 (->string field)] )]
    951                         [else
    952                                 (->string 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)]) ) )
    953954
    954955(define (fields->strings source level fields)
    955         (cond
    956                 [(null? fields) ""]
    957                 [(pair? fields) (map (cut field->string source level <>) fields)]
    958                 [else (list (field->string 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))] ) )
    959959
    960960;; (%make-log-string 0 "" "" '() str ...)
     
    988988        (let ([log #f])
    989989                ;
    990                 (set! msgs (filter-rest-argument! msgs
    991                         '(#:indent #:entry #:source #:level #:fields)))
     990                (set! msgs
     991                      (fixup-extended-lambda-list-rest '(#:indent #:entry #:source #:level #:fields)
     992                                                       msgs))
    992993                        ;
    993994                        (if (and (pair? msgs) (%log-argument? (car msgs)))
    994                                 (begin
    995                                         (set! log (car msgs))
    996                                         (set! msgs (pop! msgs)) )
    997                                 (set! log (default-logbook)) )
     995          (begin
     996            (set! log (car msgs))
     997            (set! msgs (pop! msgs)) )
     998          (set! log (default-logbook)) )
    998999                ;
    9991000                (check-log-argument log 'log-string)
     
    10221023                                [mail-line-break "\r\n"])
    10231024                (if obj
    1024                         (let ([al (uri-query obj)]
    1025                                                 [from #f]
    1026                                                 [subject #f]
    1027                                                 [bdy '()]
    1028                                                 [make-mail-header-line
    1029                                                         (lambda (key val)
    1030                                                                 (string-append
    1031                                                                         (string-titlecase (->string key))
    1032                                                                         ": "
    1033                                                                         (->string val)
    1034                                                                         mail-line-break))])
    1035                                 (let ([hdr
    1036                                                                 (map
    1037                                                                         (lambda (pair)
    1038                                                                                 (let ([key (car pair)]
    1039                                                                                                         [val (cdr pair)])
    1040                                                                                         (case key
    1041                                                                                                 [("body")
    1042                                                                                                         (set! body
    1043                                                                                                           (cons
    1044                                                                                                             (string-append (cdr pair) mail-line-break)
    1045                                                                                                             body))
    1046                                                                                                         ""]
    1047                                                                                                 [("from")
    1048                                                                                                         (set! from (cdr pair))
    1049                                                                                                         ""]
    1050                                                                                                 [("subject")
    1051                                                                                                         (set! subject (cdr pair))
    1052                                                                                                         ""]
    1053                                                                                                 [else
    1054                                                                                                         (make-mail-header-line key val)])))
    1055                                                                         (or al '()))])
    1056                                         (values
    1057                                                 (string-split (uri-encode-path obj) ",")
    1058                                                 (or from (%log-id log))
    1059                                                 (string-append
    1060                                                         (list->string hdr)
    1061                                                         (make-mail-header-line "subject" (or subject str))
    1062                                                         mail-line-break
    1063                                                         (list->string bdy)
    1064                                                         (if subject "" (string-append str mail-line-break))) ) ) )
    1065                         (values '() "" "") ) ) )
     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 '() "" "") ) ) )
    10661067
    10671068(define (log$mail-uri-handler log str errors)
     
    10701071                (let ([auth (or (uri-authority obj) (default-mail-authority))])
    10711072                        (if auth
    1072                                 (let ([host (second auth)]
    1073                                       [port (third auth)])
    1074                                         (let (
    1075                                             [smtpc
    1076                                               (smtp:connect
    1077                                                 host (get-host-name)
    1078                                                 #f (or port DEFAULT-SMTP-PORT))])
    1079                                                 (receive [tos from cntnts] (make-log-mail-string log str)
    1080                                                         (with-output-to-port (apply smtp:open smtpc from tos)
    1081                                                                 (lambda () (display cntnts)))
    1082                                                         (smtp:disconnect smtpc)
    1083                                                         #t ) ) )
    1084                                 (begin
    1085                                         (errors 'mail-uri-handler "missing authority")
    1086                                         #f) ) ) ) )
     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) ) ) ) )
    10871088
    10881089;;; Asynchronous Logging
     
    11421143        ;
    11431144        (if asynchronous?
    1144                 (asynchronous-logger-send!
    1145                         (list 'write
    1146                                 (optional-value asynchronous-error
    1147                                         (default-asynchronous-error))
    1148                                 log str echos alternates open?))
    1149                 (let ([errors (log$make-errors)])
    1150                         (unless (log$log-string log errors str echos alternates open?)
    1151                                 (log$errors '%log-string "problem with log file" log (errors)) ) ) ) )
     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)) ) ) ) )
    11521153
    11531154;; (log-string (str|log) (str|null) ...)
     
    11651166        (let ([log #f])
    11661167                ;
    1167                 (set! args (filter-rest-argument! args
    1168                         '(#:source #:level #:echos #:alternates #:open?)))
     1168                (set! args
     1169                      (fixup-extended-lambda-list-rest '(#:source #:level #:echos #:alternates #:open?)
     1170                                                       args))
    11691171                ;
    11701172                (if (%log-argument? str)
    1171                         (begin
    1172                                 (set! log str)
    1173                                 (if (null? args)
    1174                                         (log$error 'log-string "missing message")
    1175                                         (set! str (pop! args)) ) )
    1176                         (set! log (default-logbook)) )
     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)) )
    11771179                ;
    11781180                (check-log-argument log 'log-string)
     
    12711273                ;
    12721274                (set! fields
    1273                         (filter-rest-argument! fields
    1274                                 '(#:entry #:indent #:source #:level #:echos #:alternates
    1275                                         #:open? #:asynchronous? #:asynchronous-error)))
     1275                      (fixup-extended-lambda-list-rest
     1276                       '(#:entry #:indent #:source #:level #:echos #:alternates
     1277                         #:open? #:asynchronous? #:asynchronous-error)
     1278                       fields))
    12761279                ;
    12771280                (if (%log-argument? msg)
    1278                         (begin
    1279                                 (set! log msg)
    1280                                 (if (null? fields)
    1281                                         (log$error 'log-message "missing message")
    1282                                         (set! msg (pop! fields)) ) )
    1283                         (set! log (default-logbook)) )
     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)) )
    12841287                ;
    12851288                (*log-message log
     
    13111314                ;
    13121315                (set! args
    1313                         (filter-rest-argument! args
    1314                                 '(#:entry #:indent #:fields #:source #:level #:echos #:alternates
    1315                                         #:open? #:asynchronous? #:asynchronous-error)))
     1316                      (fixup-extended-lambda-list-rest
     1317                       '(#:entry #:indent #:fields #:source #:level #:echos #:alternates
     1318                         #:open? #:asynchronous? #:asynchronous-error)
     1319                       args))
    13161320                ;
    13171321                (if (%log-argument? format-string)
    1318                         (begin
    1319                                 (set! log format-string)
    1320                                 (if (null? args)
    1321                                         (log$error 'log-format "missing format-string")
    1322                                         (set! format-string (pop! args)) ) )
    1323                         (set! log (default-logbook)) )
     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)) )
    13241328                ;
    13251329                (check-string format-string 'log-format)
  • release/3/logging/trunk/logging.setup

    r9025 r9026  
    99  'mailbox                "1.1"
    1010  's11n                   "0.9"
    11   'mathh                  "1.9.2"
     11  'mathh                  "1.11"
    1212  'smtp                   "1.2"
    1313  'z3                     "1.36" )
Note: See TracChangeset for help on using the changeset viewer.