* src/logging/logger.scm (log-helper): Retrieve procedure name and
pass it to `accept-log'.
(default-log-formatter): Register new proc-name keyword argument, and
include it in formatted message.
(accept-log): New proc-name positional argument; pass it to log-formatter.
* unit-tests/guile-library.api: Regenerate.
---
(no changes since v1)
src/logging/logger.scm | 22 ++++++++++++++--------
unit-tests/guile-library.api | 2 +-
2 files changed, 15 insertions(+), 9 deletions(-)
diff --git a/src/logging/logger.scm b/src/logging/logger.scm
index 05850a9..7085d26 100644
--- a/src/logging/logger.scm
+++ b/src/logging/logger.scm
@@ -222,13 +222,14 @@ Handlers can always be added later via
@code{add-handler!} calls.
(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)))
+ (let ((cur-time (current-time))
+ (proc-name (frame-procedure-name (stack-ref (make-stack #t) 2))))
(for-each (lambda (str)
(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))
+ source-properties proc-name))
(handlers lgr))))
;; split the string at newlines into different log statements
@@ -283,21 +284,25 @@ timestamps to log statements.
;; 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
- #:key source-properties
+ #:key source-properties proc-name
#: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)."
+suitable syntax wrapper (currently left to the user to implement).
+@var{proc-name}, if available, is the name of the procedure the
+message was logged from."
(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~%"
+ (format #f "~a ~@[~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))
+ (format #f "~@[~a:~]~@[~a:~]~@[~a:~]"
+ file-name line column))
+ proc-name
lvl
str)))
@@ -352,10 +357,11 @@ 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
- source-properties)
+ source-properties proc-name)
(when (level-enabled? self level)
(emit-log self ((log-formatter self) level time str
- #:source-properties source-properties))))
+ #:source-properties source-properties
+ #:proc-name proc-name))))
;; This should be overridden by all log handlers to actually
;; write out a string.
diff --git a/unit-tests/guile-library.api b/unit-tests/guile-library.api
index 594a1ab..e879b9d 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> <top>))
+ (<log-handler> <top> <top> <top> <top> <top>))
(add-handler! generic (<logger> <log-handler>))
(close-log!
generic
--
2.41.0
