[slime-devel] [patch] add a new protocol message for outputting images

[Stanislaw Halik]

Here's a new protocol message for outputting images. Unlike the previous
approach, it doesn't rely upon EVAL-IN-EMACS. The Bad Thing is that it
puts REPL-specific code inside DISPATCH-EVENT which should be
contrib-agnostic. There seems to be no way to add protocol messages in
contribs, maybe there's some better way not involving protocol messages.

I added the `fake-p' stuff because if it isn't there, the image is
displayed right before the last REPL result (maybe dependent upon
presentations?).

PS in the last commit I got credited as "StanisBaw". The "ł" character
apparently got turned into this "B". It can be transliterated to ASCII
as "l" if the changelog has problems with Unicode.

diff --git a/contrib/slime-repl.el b/contrib/slime-repl.el
index 9e05531..3bcb894 100644
--- a/contrib/slime-repl.el
+++ b/contrib/slime-repl.el
@@ -719,23 +719,27 @@ balanced."
       (goto-char (point-max))
       (recenter -1))))
 
-(defun slime-repl-send-input (&optional newline)
+(defun slime-repl-send-input (&optional newline fake-p)
   "Goto to the end of the input and send the current input.
-If NEWLINE is true then add a newline at the end of the input."
+If NEWLINE is true then add a newline at the end of the input.
+When FAKE-P is true it doesn't get added to history. Useful for
+adding images to the REPL."
   (unless (slime-repl-in-input-area-p)
     (error "No input at point."))
   (goto-char (point-max))
   (let ((end (point))) ; end of input, without the newline
-    (slime-repl-add-to-input-history 
-     (buffer-substring slime-repl-input-start-mark end))
+    (unless fake-p
+      (slime-repl-add-to-input-history 
+       (buffer-substring slime-repl-input-start-mark end)))
     (when newline 
       (insert "\n")
       (slime-repl-show-maximum-output))
-    (let ((inhibit-modification-hooks t))
-      (add-text-properties slime-repl-input-start-mark 
-                           (point)
-                           `(slime-repl-old-input
-                             ,(incf slime-repl-old-input-counter))))
+    (unless fake-p
+      (let ((inhibit-modification-hooks t))
+        (add-text-properties slime-repl-input-start-mark 
+                             (point)
+                             `(slime-repl-old-input
+                               ,(incf slime-repl-old-input-counter)))))
     (let ((overlay (make-overlay slime-repl-input-start-mark end)))
       ;; These properties are on an overlay so that they won't be taken
       ;; by kill/yank.
@@ -745,7 +749,8 @@ If NEWLINE is true then add a newline at the end of the input."
     (goto-char (point-max))
     (slime-mark-input-start)
     (slime-mark-output-start)
-    (slime-repl-send-string input)))
+    (unless fake-p
+      (slime-repl-send-string input))))
 
 (defun slime-repl-grab-old-input (replace)
   "Resend the old REPL input at point.  
diff --git a/slime.el b/slime.el
index c392996..e60a022 100644
--- a/slime.el
+++ b/slime.el
@@ -2392,6 +2392,12 @@ Debugged requests are ignored."
   (let ((slime-dispatching-connection (or process (slime-connection))))
     (or (run-hook-with-args-until-success 'slime-event-hooks event)
         (destructure-case event
+          ((:write-image pathname)
+           (if (file-exists-p pathname)
+               (with-current-buffer (slime-repl-buffer)
+                 (insert-image (create-image pathname))
+                 (slime-repl-send-input t t))
+               (error "No such file: '%s'" pathname)))
           ((:emacs-rex form package thread continuation)
            (when (and (slime-use-sigint-for-interrupt) (slime-busy-p))
              (slime-display-oneliner "; pipelined request... %S" form))
diff --git a/swank.lisp b/swank.lisp
index 9b1f0f4..a259797 100644
--- a/swank.lisp
+++ b/swank.lisp
@@ -1174,7 +1174,16 @@ The processing is done in the extent of the toplevel restart."
     ((:reader-error packet condition)
      (encode-message `(:reader-error ,packet 
                                      ,(safe-condition-message condition))
-                     (current-socket-io)))))
+                     (current-socket-io)))
+    ((:write-image pathname)
+     (handler-case (namestring (truename pathname))
+       (error (e)
+         (declare (ignore e))
+         nil)
+       (:no-error (string)
+         (when string
+           (encode-message `(:write-image ,string)
+                           (current-socket-io))))))))
 
 (defvar *event-queue* '())
 (defvar *events-enqueued* 0)
@@ -3845,4 +3854,4 @@ Collisions are caused because package information is ignored."
 (defun init ()
   (run-hook *after-init-hook*))
 
-;;; swank.lisp ends here
\ No newline at end of file
+;;; swank.lisp ends here