* 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
