unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* [Guile-Lib PATCH] logger: Add flush-after-emit? property to <log-handler>.
@ 2024-03-02  4:15 Maxim Cournoyer
  2024-03-02 23:28 ` David Pirotte
  0 siblings, 1 reply; 6+ messages in thread
From: Maxim Cournoyer @ 2024-03-02  4:15 UTC (permalink / raw)
  To: guile-devel; +Cc: David Pirotte, Maxim Cournoyer

* 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 <david@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




^ permalink raw reply related	[flat|nested] 6+ messages in thread

end of thread, other threads:[~2024-03-10  1:46 UTC | newest]

Thread overview: 6+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2024-03-02  4:15 [Guile-Lib PATCH] logger: Add flush-after-emit? property to <log-handler> Maxim Cournoyer
2024-03-02 23:28 ` David Pirotte
2024-03-03  3:26   ` Maxim Cournoyer
2024-03-04  6:19     ` David Pirotte
2024-03-05 17:03       ` Maxim Cournoyer
2024-03-10  1:46         ` David Pirotte

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).