1 ! Copyright (C) 2003, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: logging.server sequences namespaces concurrency.messaging
4 words kernel arrays shuffle tools.annotations
5 prettyprint.config prettyprint debugger io.streams.string
6 splitting continuations effects generalizations parser strings
7 quotations fry accessors math assocs math.order
8 sequences.generalizations ;
11 SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;
15 log-level [ DEBUG ] initialize
17 : log-levels ( -- assoc )
26 ERROR: undefined-log-level ;
28 : log-level<=> ( log-level log-level -- <=> )
29 [ log-levels at* [ throw-undefined-log-level ] unless ] compare ;
31 : log? ( log-level -- ? )
32 log-level get log-level<=> +lt+ = not ;
34 : send-to-log-server ( array string -- )
35 prefix "log-server" get send ;
39 ERROR: bad-log-message-parameters msg word level ;
41 : check-log-message ( msg word level -- msg word level )
42 3dup [ string? ] [ word? ] [ word? ] tri* and and
43 [ throw-bad-log-message-parameters ] unless ; inline
45 : log-message ( msg word level -- )
48 2dup [ log? ] [ ] bi* and [
49 [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip
50 4array "log-message" send-to-log-server
56 { } "rotate-logs" send-to-log-server ;
59 { } "close-logs" send-to-log-server ;
61 : with-logging ( service quot -- )
62 [ log-service ] dip with-variable ; inline
64 ! Aspect-oriented programming idioms
68 : stack>message ( obj -- inputs>message )
69 dup array? [ dup length 1 = [ first ] when ] when
83 : (define-logging) ( word level quot -- )
84 [ dup ] 2dip 2curry annotate ; inline
86 : call-logging-quot ( quot word level -- quot' )
87 [ "called" ] 2dip [ log-message ] 3curry prepose ;
89 : add-logging ( word level -- )
90 [ call-logging-quot ] (define-logging) ;
92 : log-stack ( n word level -- )
94 [ [ ndup ] keep narray stack>message ] 2dip log-message
99 : input# ( word -- n ) stack-effect in>> length ;
101 : input-logging-quot ( quot word level -- quot' )
102 rot [ [ input# ] keep ] 2dip '[ _ _ _ log-stack @ ] ;
104 : add-input-logging ( word level -- )
105 [ input-logging-quot ] (define-logging) ;
107 : output# ( word -- n ) stack-effect out>> length ;
109 : output-logging-quot ( quot word level -- quot' )
110 [ [ output# ] keep ] dip '[ @ _ _ _ log-stack ] ;
112 : add-output-logging ( word level -- )
113 [ output-logging-quot ] (define-logging) ;
115 : (log-error) ( object word level -- )
117 [ [ print-error ] with-string-writer ] 2dip log-message
122 : log-error ( error word -- ) ERROR (log-error) ;
124 : log-critical ( error word -- ) CRITICAL (log-error) ;
126 : stack-balancer ( effect -- quot )
127 [ in>> length [ ndrop ] curry ]
128 [ out>> length f <repetition> >quotation ]
131 : error-logging-quot ( quot word -- quot' )
132 dup stack-effect stack-balancer
133 '[ _ [ _ log-error @ ] recover ] ;
135 : add-error-logging ( word level -- )
136 [ [ input-logging-quot ] 2keep drop error-logging-quot ]
140 #! Syntax: name level
141 scan-new-word dup scan-word
142 '[ 1array stack>message _ _ log-message ]
143 ( message -- ) define-declared ;
147 "logging.parser" require
148 "logging.analysis" require