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 keyword argument,
that is formatted as a source location prefix when available. Add
#:allow-other-keys to signal users they should use such a signature
to ensure forward compatibility.
(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.
---
Changes in v3:
- Use (ice-9 format) for the default-log-formatter
- Use a keyword argument for the source-properties
- Add proc-name argument to default-log-formatter
Changes in v2:
- Relax log-msg typing on source-properties, as it can also be #f
src/logging/logger.scm | 95 ++++++++++++++++++++++-------------
unit-tests/guile-library.api | 8 +--
unit-tests/logging.logger.scm | 12 +++++
3 files changed, 78 insertions(+), 37 deletions(-)
diff --git a/src/logging/logger.scm b/src/logging/logger.scm
index 7ff4f43..7b32ffe 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.courno...@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 format)
#: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,22 +267,39 @@ 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 (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
+ (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)
- (with-output-to-string
- (lambda ()
- (display (strftime "%F %H:%M:%S" (localtime time)))
- (display " (")
- (display (symbol->string lvl))
- (display "): ")
- (display str)
- (newline))))
+(define* (default-log-formatter lvl time str
+ #:key source-properties
+ #:allow-other-keys)
+ "Default log formatting procedure. For source properties to be
+available, they must be manually provided to @code{log-msg} via a
+suitable syntax wrapper (currently left to the user to implement)."
+ (let ((file-name (assoc-ref source-properties 'filename))
+ ;; Note: increment the source property zero-indexed line by 1,
+ ;; to comply with the GNU Standards guidelines (info
+ ;; '(standards) Errors').
+ (line (and=> (assoc-ref source-properties 'line) 1+))
+ (column (assoc-ref source-properties 'column)))
+ (format #f "~a ~@[~a ~](~a): ~a~%"
+ (strftime "%F %H:%M:%S" (localtime time))
+ (and (or file-name line column)
+ (format #f "~@[~a:~]~@[~a:~]~@[~a:~]" file-name line column))
+ lvl
+ str)))
(define-class-with-docs <log-handler> ()
"This is the base class for all of the log handlers, and encompasses
@@ -314,10 +336,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 +351,13 @@ 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 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..594a1ab 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,8 +114,10 @@
(<rotating-log>))
(log-msg
generic
- (<logger> <top> . <top>)
- (<symbol> . <top>))
+ (<logger> <symbol> . <top>)
+ (<logger> <top> <symbol> . <top>)
+ (<symbol> . <top>)
+ (<top> <symbol> . <top>))
(lookup-logger procedure (arity 1 0 #f))
(open-log!
generic
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.courno...@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
