* 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 6a5b824..b75d603 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 #:key 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 @@ -285,21 +286,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))) @@ -359,10 +364,11 @@ override this behavior.") (emit-log self ((log-formatter self) level time str)))) (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