* src/logging/logger.scm (<log-handler>): Add new optional flush-after-each-emit? slot, initialized to #t.
(accept-log) [flush-after-each-emit?]: Flush log when condition is true. * unit-tests/logging.logger.scm (call-with-temporary-file): New procedure. (test-log-with-flush-after-emit-disabled): New test. (test-log-with-flush-after-emit): Likewise. Suggested-by: David Pirotte <da...@altosw.be> --- src/logging/logger.scm | 21 ++++++++++++++++----- unit-tests/logging.logger.scm | 31 +++++++++++++++++++++++++++++++ 2 files changed, 47 insertions(+), 5 deletions(-) diff --git a/src/logging/logger.scm b/src/logging/logger.scm index 6e488f6..0bec407 100644 --- a/src/logging/logger.scm +++ b/src/logging/logger.scm @@ -309,7 +309,7 @@ message was logged from." str))) (define-class-with-docs <log-handler> () -"This is the base class for all of the log handlers, and encompasses + "This is the base class for all of the log handlers, and encompasses the basic functionality that all handlers are expected to have. Keyword arguments recognized by the @code{<log-handler>} at creation time are: @@ -328,9 +328,18 @@ output looks like: \"The servers are melting!\") ==> \"2003/12/29 14:53:02 (CRITICAL): The servers are melting!\" @end lisp +@item #:flush-after-emit? +This optional parameter defaults to @code{#t}, to ensure users can +tail the logs output in real time. In some cases, such as when +logging very large output to a file, it may be preferable to set this +to @code{#f}, to let the default block buffering mode of the +associated file port reduce write pressure on the file system. @end table" - (formatter #:init-value default-log-formatter #:getter log-formatter #:init-keyword #:formatter) - (levels #:init-form (make-hash-table 17) #:getter levels)) + (formatter #:init-value default-log-formatter #:getter log-formatter + #:init-keyword #:formatter) + (levels #:init-form (make-hash-table 17) #:getter levels) + (flush-after-emit? #:init-value #t #:getter flush-after-emit? + #:init-keyword #:flush-after-emit?)) (define-generic-with-docs add-handler! "@code{add-handler! lgr handler}. Adds @var{handler} to @var{lgr}'s list of handlers. All subsequent @@ -364,7 +373,8 @@ override this behavior.") ;; Legacy variant without source-properties argument. (when (level-enabled? self level) (emit-log self ((log-formatter self) level time str)) - (flush-log self))) + (when (flush-after-emit? self) + (flush-log self)))) (define-method (accept-log (self <log-handler>) level time str source-properties proc-name) @@ -372,7 +382,8 @@ override this behavior.") (emit-log self ((log-formatter self) level time str #:source-properties source-properties #:proc-name proc-name)) - (flush-log self))) + (when (flush-after-emit? self) + (flush-log self)))) ;; This should be overridden by all log handlers to actually ;; write out a string. diff --git a/unit-tests/logging.logger.scm b/unit-tests/logging.logger.scm index 534c65e..2cead80 100644 --- a/unit-tests/logging.logger.scm +++ b/unit-tests/logging.logger.scm @@ -21,8 +21,15 @@ (use-modules (unit-test) (logging logger) (logging port-log) + (ice-9 textual-ports) (oop goops)) +(define* (call-with-temporary-file proc #:key (mode "w+")) + "Open a temporary file name and pass it to PROC, a procedure of one +argument. The port is automatically closed." + (let ((port (mkstemp "file-XXXXXX" mode))) + (call-with-port port proc))) + (define-class <test-logging> (<test-case>)) (define-method (test-log-to-one-port (self <test-logging>)) @@ -65,4 +72,28 @@ (assert (string-contains (get-output-string strport) " unit-tests/logging.logger.scm:63:4: ")))) +(define-method (test-log-with-flush-after-emit-disabled (self <test-logging>)) + "Test the case where flush-after-emit? on the handler is false." + (call-with-temporary-file + (lambda (port) + (setvbuf port 'block 1000000) ;large 1MB buffer + (let ((lgr (make <logger> + #:handlers (list (make <port-log> #:port port + #:flush-after-emit? #f))))) + (log-msg lgr 'ERROR "this should be buffered, i.e. not written yet") + (assert (string-null? + (call-with-input-file (port-filename port) get-string-all))))))) + +(define-method (test-log-with-flush-after-emit (self <test-logging>)) + "Test the default case where flush-after-emit? on the handler is true." + (call-with-temporary-file + (lambda (port) + (setvbuf port 'block 1000000) ;large 1MB buffer + (let ((lgr (make <logger> + #:handlers (list (make <port-log> #:port port))))) + (log-msg lgr 'ERROR "this should be flushed to disk after emit") + (assert (string-contains + (call-with-input-file (port-filename port) get-string-all) + "this should be flushed to disk after emit")))))) + (exit-with-summary (run-all-defined-test-cases)) base-commit: af929893752b076f367d9d18d2b5e0e8ac12bf7b -- 2.41.0