xxx

xxx.md

diff --git a/src/logger.lisp b/src/logger.lisp
index ad781af..ae19912 100644
--- a/src/logger.lisp
+++ b/src/logger.lisp
@@ -520,7 +520,7 @@ context of the current application."
                        (is-enabled-for ,logger-symbol ,level))
                  (flet ((,log-stmt (,stream)
                           (declare (type stream ,stream))
-                          (format ,stream ,@args)))
+                          (user-log-message ,stream ,@args)))
                    (declare (dynamic-extent #',log-stmt))
                    (locally (declare (optimize (safety 0) (debug 0) (speed 3)))
                      (log-with-logger ,logger-symbol ,level #',log-stmt ,pkg-hint))))
diff --git a/src/naming.lisp b/src/naming.lisp
index cc2559c..53c0a73 100644
--- a/src/naming.lisp
+++ b/src/naming.lisp
@@ -152,6 +152,13 @@ values, for example for the :AROUND method FOO with lambda list
 of ((OBJ1 BAR) (OPTION (EQL :BAZ)) OBJ3) should strive to return
 '(FOO AROUND BAR BAZ) "))
 
+(defgeneric user-log-message (stream control-string &rest args)
+  (:documentation "Is called to format a message on the stream. Should
+be specialized on the first argument. CONTROL-STRING is specified as
+for FORMAT function.")
+  (:method (stream control-string &rest args)
+    (apply #'format stream control-string args)))
+
 #-(or sbcl ccl)
 (defmethod enclosing-scope-block-name (package env)
   "Default method that always return NIL"

#-mcclim
(eval-when (:load-toplevel :compile-toplevel :execute)
  (ql:quickload '(mcclim log4cl)))

(in-package #:clim-user)

(defclass log-message (clim:device-event)
  ((logger    :initarg :logger)
   (level     :initarg :level)
   (log-func  :initarg :log-func))
  (:default-initargs :modifier-state nil))

(defclass clim-appender (log4cl:appender clim:application-pane)
  ()
  (:default-initargs :display-time nil))

(defmethod log4cl:appender-do-append ((appender clim-appender) logger level log-func)
  (queue-event appender (make-instance 'log-message
                                       :sheet appender
                                       :logger logger
                                       :level level
                                       :log-func log-func)))

(clim:define-presentation-type argument ())
(clim:define-presentation-method clim:present ((object t) (type argument) stream view &key)
  (princ object stream))
(defparameter *as-presentation-pprint-dispatch*
  (let* ((default-pprint-dispatch *print-pprint-dispatch*)
         (dispatch                (copy-pprint-dispatch default-pprint-dispatch)))
    (set-pprint-dispatch
     't (lambda (stream object)
          (let ((*print-pprint-dispatch* default-pprint-dispatch)
                (stream (sb-pretty::pretty-stream-target stream)))
            (clim:with-drawing-options (stream :ink clim:+dark-blue+ :text-face :bold)
              (clim:present object 'argument :stream stream))))
     100 dispatch)
    dispatch))

(defmethod log4cl::user-log-message ((stream clim-appender) control-string &rest args)
  (clim:with-text-family (stream :fix)
    (let ((*print-pprint-dispatch* *as-presentation-pprint-dispatch*))
      (call-next-method))))

(defmethod clim:handle-event ((client clim-appender) (event log-message))
  (with-slots (logger level log-func) event
    (log4cl:layout-to-stream (log4cl:appender-layout client) client logger level log-func)))

(define-application-frame my-test ()
  ()
  (:pointer-documentation t)
  (:pane clim-appender))

(define-my-test-command (add-appender :menu t) ()
  (log4cl:add-appender log4cl:*root-logger* *standard-output*))

(defun doc-hint (object &key stream &allow-other-keys)
  (format stream "type: ~a" (presentation-type-of object)))

(define-presentation-action hint (argument nil my-test :pointer-documentation doc-hint)
    (object)
  nil)

(bt:make-thread (lambda () (run-frame-top-level (make-application-frame 'my-test))))