[Guile-Lib PATCH v4 6/7] logging: Make procedure name available to the log formatter.

[Maxim Cournoyer <maxim.cournoyer@gmail.com>]

* 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