[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-Lib PATCH 4/6] logging: Allow passing source properties to `log-m
From: |
Maxim Cournoyer |
Subject: |
[Guile-Lib PATCH 4/6] logging: Allow passing source properties to `log-msg'. |
Date: |
Mon, 5 Feb 2024 14:40:34 -0500 |
Note: this changes the API of the `accept-log' method by adding a new
positional argument to it. `accept-log' is a "weak" public
interface (mostly intended for internal uses or logging handler
implementors), so this is deemed acceptable.
* src/logging/logger.scm (log-helper) [source-properties]: New
positional argument, which is passed to `accept-log'.
* src/logging/logger.scm (log-msg): Update doc. Add two new variants
that accept source properties. Annotate more LVL arguments with their
type to ensure proper resolution.
(default-log-formatter) [source-properties]: New optional argument,
that is formatted as a source location prefix when available.
(accept-log): Update doc. Add new source-properties argument, and
pass it to the log-formatter procedure.
* unit-tests/logging.logger.scm
(test-log-with-source-properties): New test.
* unit-tests/guile-library.api: Regenerate.
---
src/logging/logger.scm | 82 ++++++++++++++++++++++++-----------
unit-tests/guile-library.api | 6 ++-
unit-tests/logging.logger.scm | 12 +++++
3 files changed, 72 insertions(+), 28 deletions(-)
diff --git a/src/logging/logger.scm b/src/logging/logger.scm
index 7ff4f43..982c44d 100644
--- a/src/logging/logger.scm
+++ b/src/logging/logger.scm
@@ -1,5 +1,6 @@
;; (logging logger) -- write methods to log files
-;; Copyright (C) 2003 Richard Todd
+;; Copyright (C) 2003 Richard Todd
+;; Copyright (C) 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -68,6 +69,7 @@ INFO and WARN-level logs don't get through.
(use-modules (logging logger)
(logging rotating-log)
(logging port-log)
+
(scheme documentation)
(oop goops))
@@ -143,6 +145,7 @@ INFO and WARN-level logs don't get through.
close-log!
)
#:use-module (oop goops)
+ #:use-module (ice-9 match)
#:use-module (scheme documentation))
;;; ----------------------------------------------------------------------
@@ -216,17 +219,17 @@ Handlers can always be added later via
@code{add-handler!} calls.
(levels #:init-form (make-hash-table 17) #:getter levels)
(log-handlers #:init-value '() #:accessor handlers #:init-keyword
#:handlers))
-(define (log-helper lgr level objs)
+(define (log-helper lgr level objs source-properties)
;; the level must be enabled in the logger to proceed...
(if (level-enabled? lgr level)
(let ((cur-time (current-time)))
(for-each (lambda (str)
- (if (not (string-null? str))
-
- ;; pass the string to each log handler for lgr
- (for-each (lambda (handler)
- (accept-log handler level cur-time str))
- (handlers lgr))))
+ (unless (string-null? str)
+ ;; pass the string to each log handler for lgr
+ (for-each (lambda (handler)
+ (accept-log handler level cur-time str
+ source-properties))
+ (handlers lgr))))
;; split the string at newlines into different log statements
(string-split
@@ -234,15 +237,17 @@ Handlers can always be added later via
@code{add-handler!} calls.
#\nl)))))
(define-generic-with-docs log-msg
-"@code{log-msg [lgr] lvl arg1 arg2 ...}. Send a log message
-made up of the @code{display}'ed representation of the given
-arguments. The log is generated at level @var{lvl}, which should
-be a symbol. If the @var{lvl} is disabled, the log message is
+"@code{log-msg [lgr] [source-properties] lvl arg1 arg2 ...}. Send a
+log message made up of the @code{display}'ed representation of the
+given arguments. The log is generated at level @var{lvl}, which
+should be a symbol. If the @var{lvl} is disabled, the log message is
not generated. Generated log messages are sent through each of
@var{lgr}'s handlers.
-If the @var{lgr} parameter is omitted, then the default logger
-is used, if one is set.
+If the @var{lgr} parameter is omitted, then the default logger is
+used, if one is set. If the @var{source-properties} argument is
+provided, it should be a source property alist containing the
+filename, line and column keys.
As the args are @code{display}'ed, a large string is built up. Then,
the string is split at newlines and sent through the log handlers as
@@ -262,17 +267,38 @@ timestamps to log statements.
(define-method (log-msg (lvl <symbol>) . objs)
(if default-logger
- (log-helper default-logger lvl objs)))
+ (log-helper default-logger lvl objs #f)))
+
+(define-method (log-msg (source-properties <pair>) (lvl <symbol>) . objs)
+ (if default-logger
+ (log-helper default-logger lvl objs source-properties)))
+
+(define-method (log-msg (lgr <logger>) (lvl <symbol>) . objs)
+ (log-helper lgr lvl objs #f))
-(define-method (log-msg (lgr <logger>) lvl . objs)
- (log-helper lgr lvl objs))
+(define-method (log-msg (lgr <logger>) (source-properties <pair>)
+ (lvl <symbol>) . objs)
+ (log-helper lgr lvl objs source-properties))
;; the default formatter makes a log statement like:
;; 2003/12/29 14:53:02 (CRITICAL): The servers are melting!
-(define (default-log-formatter lvl time str)
+(define* (default-log-formatter lvl time str #:optional source-properties)
+ "Default log formatting procedure. For source properties to be
+available, they must be manually provided to `log-msg' via a suitable
+syntactic wrapper (currently left to the user to implement)."
(with-output-to-string
(lambda ()
(display (strftime "%F %H:%M:%S" (localtime time)))
+ (match source-properties
+ (#f #f)
+ ;; Note: increment the source property zero-indexed line by 1,
+ ;; to comply with the GNU Standards guidelines (info
+ ;; '(standards) Errors').
+ ((('line . line) ('column . column))
+ ;; The file name may be missing (e.g. when evaluating at the REPL).
+ (format #t " ~a:~a:" (1+ line) column))
+ ((('filename . file-name) ('line . line) ('column . column))
+ (format #t " ~a:~a:~a:" file-name (1+ line) column)))
(display " (")
(display (symbol->string lvl))
(display "): ")
@@ -314,10 +340,13 @@ registered handlers.")
(define-generic-with-docs accept-log
"@code{accept-log handler lvl time str}. If @var{lvl} is
-enabled for @var{handler}, then @var{str} will be formatted and
-sent to the log via the @code{emit-log} method. Formatting is
-done via the formatting function given at @var{handler}'s
-creation time, or by the default if none was given.
+enabled for @var{handler}, then @var{str} will be formatted and sent
+to the log via the @code{emit-log} method. @var{source-properties}
+can be either @code{#f} or an association list containing the file
+name, line, and column source information provided to the
+@code{log-msg} call. Formatting is done via the formatting function
+given at @var{handler}'s creation time, or by the default if none was
+given.
This method should not normally need to be overridden by subclasses.
This method should not normally be called by users of the logging
@@ -326,11 +355,12 @@ override this behavior.")
;; This can be overridden by log handlers if this default behaviour
;; is not desired..
-(define-method (accept-log (self <log-handler>) level time str)
- (if (level-enabled? self level)
- (emit-log self ((log-formatter self) level time str))))
+(define-method (accept-log (self <log-handler>) level time str
+ source-properties)
+ (when (level-enabled? self level)
+ (emit-log self ((log-formatter self) level time str source-properties))))
-;; This should be overridden by all log handlers to actually
+;; This should be overridden by all log handlers to actually
;; write out a string.
(define-generic-with-docs emit-log
"@code{emit-log handler str}. This method should be implemented
diff --git a/unit-tests/guile-library.api b/unit-tests/guile-library.api
index b52dd41..6235d94 100644
--- a/unit-tests/guile-library.api
+++ b/unit-tests/guile-library.api
@@ -90,7 +90,7 @@
(<logger> class)
(accept-log
generic
- (<log-handler> <top> <top> <top>))
+ (<log-handler> <top> <top> <top> <top>))
(add-handler! generic (<logger> <log-handler>))
(close-log!
generic
@@ -114,7 +114,9 @@
(<rotating-log>))
(log-msg
generic
- (<logger> <top> . <top>)
+ (<logger> <pair> <symbol> . <top>)
+ (<logger> <symbol> . <top>)
+ (<pair> <symbol> . <top>)
(<symbol> . <top>))
(lookup-logger procedure (arity 1 0 #f))
(open-log!
diff --git a/unit-tests/logging.logger.scm b/unit-tests/logging.logger.scm
index f1084b8..d26587c 100644
--- a/unit-tests/logging.logger.scm
+++ b/unit-tests/logging.logger.scm
@@ -1,6 +1,7 @@
;;; ----------------------------------------------------------------------
;;; unit test
;;; Copyright (C) 2003 Richard Todd
+;;; Copyright (C) 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
@@ -52,6 +53,17 @@
(assert-equal "(CRITICAL): Hello!\n"
;; skip over the time/date, since that will vary!
(substring (get-output-string strport) 20))))
+
+(define-method (test-log-with-source-properties (self <test-logging>))
+ (let* ((strport (open-output-string))
+ (lgr (make <logger> #:handlers (list (make <port-log> #:port
strport))))
+ (source-properties '((filename . "unit-tests/logging.logger.scm")
+ (line . 62)
+ (column . 4))))
+ (open-log! lgr)
+ (log-msg lgr source-properties 'ERROR "Hello!")
+ (string-contains (get-output-string strport)
+ " unit-tests/logging.logger.scm:63:4: ")))
(exit-with-summary (run-all-defined-test-cases))
--
2.41.0
- [Guile-Lib PATCH 0/6] Make log-msg accept source properties for displaying source location, Maxim Cournoyer, 2024/02/05
- [Guile-Lib PATCH 1/6] configure.ac: Fix typo in message., Maxim Cournoyer, 2024/02/05
- [Guile-Lib PATCH 2/6] Use /bin/sh in update-api script shebang., Maxim Cournoyer, 2024/02/05
- [Guile-Lib PATCH 3/6] tests: guile-library.api: Re-generate., Maxim Cournoyer, 2024/02/05
- [Guile-Lib PATCH 4/6] logging: Allow passing source properties to `log-msg'.,
Maxim Cournoyer <=
- [Guile-Lib PATCH 5/6] logging: Adjust default log-formatter output., Maxim Cournoyer, 2024/02/05
- [Guile-Lib PATCH 6/6] logger: Call flush-log at the end of accept-log., Maxim Cournoyer, 2024/02/05