[beirc-cvs] CVS beirc
afuchs
afuchs at common-lisp.net
Thu Apr 20 06:39:27 UTC 2006
Update of /project/beirc/cvsroot/beirc
In directory clnet:/tmp/cvs-serv18310
Modified Files:
application.lisp presentations.lisp
Log Message:
Catch bad input on the interactor and present it in a way that allows re-editing.
Works in mcclim only, sorry.
--- /project/beirc/cvsroot/beirc/application.lisp 2006/04/20 02:23:56 1.78
+++ /project/beirc/cvsroot/beirc/application.lisp 2006/04/20 06:39:27 1.79
@@ -444,6 +444,11 @@
(define-window-switcher com-window-next (:next :control) 1 (constantly t))
(define-window-switcher com-window-previous (:prior :control) -1 (constantly t))))
+(define-beirc-command (com-insert-input :name t) ((input 'bad-input))
+ (setf (incomplete-input (current-receiver *application-frame*))
+ (concatenate 'string (incomplete-input (current-receiver *application-frame*))
+ input)))
+
(define-beirc-command (com-close :name t) ((receivers '(sequence receiver) :prompt "tab" :default (list (current-receiver *application-frame*))))
(dolist (receiver receivers)
(let* ((connection (connection receiver))
@@ -703,6 +708,16 @@
(beep))
#+sbcl (simple-error (e) (format t "~a" e))))
+(define-presentation-to-command-translator incomplete-input-to-input-translator
+ (bad-input com-insert-input beirc
+ :menu nil
+ :gesture :select
+ :documentation "Append this to the input line"
+ :pointer-documentation "Append this to the input line"
+ :priority 10)
+ (object)
+ (list object))
+
(define-presentation-to-command-translator nickname-to-ignore-translator
(nickname com-ignore beirc
:menu t
@@ -969,7 +984,8 @@
(with-output-to-string (s)
(loop for elt across buffer
if (characterp elt)
- do (write-char elt s)))))))
+ do (write-char elt s))))
+ (incomplete-input (current-receiver frame)))))
(define-condition invoked-command-by-clicking ()
()
@@ -1013,48 +1029,69 @@
(call-next-method))
(defmethod read-frame-command ((frame beirc) &key (stream *standard-input*))
- (unwind-protect
- (clim:with-input-editing (stream)
- (when (and (current-receiver frame) (incomplete-input (current-receiver frame)))
- (replace-input stream (incomplete-input (current-receiver frame)) :rescan t))
- (with-input-context ('command) (object)
- (with-command-table-keystrokes (*accelerator-gestures* (frame-command-table frame))
- (catch 'keystroke-command
- (let ((force-restore-input-state nil))
- (labels ((reset-saved-input ()
- (when (current-receiver frame)
- (setf (incomplete-input (current-receiver frame)) ""))))
- (handler-bind ((accelerator-gesture
- (lambda (gesture)
- (save-input-line stream frame)
- (throw 'keystroke-command (lookup-keystroke-command-item
- (accelerator-gesture-event gesture)
- (frame-command-table frame)))))
- (abort-gesture
- (lambda (gesture)
- (declare (ignore gesture))
- (reset-saved-input)
- (setf force-restore-input-state nil)))
- (invoked-command-by-clicking
- (lambda (cond)
- (declare (ignore cond))
- (save-input-line stream frame)
- (setf force-restore-input-state t)
- (invoke-restart 'acknowledged))))
- (let ((c (clim:read-gesture :stream stream :peek-p t)))
- (multiple-value-prog1
- (cond ((eql c #\/)
- (clim:read-gesture :stream stream)
- (accept 'command :stream stream :prompt nil))
- (t
- (list 'com-say (accept 'mumble :history 'mumble :prompt nil :stream stream))))
- (if force-restore-input-state
- (setf force-restore-input-state nil)
- (reset-saved-input)))))))))
- (command
- (save-input-line stream frame)
- object)))
- (window-clear stream)))
+ (let ((bad-input nil))
+ (unwind-protect
+ (clim:with-input-editing (stream)
+ (when (and (current-receiver frame) (incomplete-input (current-receiver frame)))
+ (replace-input stream (incomplete-input (current-receiver frame)) :rescan t))
+ (with-input-context ('command) (object)
+ (with-command-table-keystrokes (*accelerator-gestures* (frame-command-table frame))
+ (catch 'keystroke-command
+ (let ((force-restore-input-state nil))
+ (labels ((reset-saved-input ()
+ (when (current-receiver frame)
+ (setf (incomplete-input (current-receiver frame)) ""))))
+ (handler-bind ((accelerator-gesture
+ (lambda (gesture)
+ (save-input-line stream frame)
+ (throw 'keystroke-command (lookup-keystroke-command-item
+ (accelerator-gesture-event gesture)
+ (frame-command-table frame)))))
+ (abort-gesture
+ (lambda (gesture)
+ (declare (ignore gesture))
+ (reset-saved-input)
+ (setf force-restore-input-state nil)))
+ (invoked-command-by-clicking
+ (lambda (cond)
+ (declare (ignore cond))
+ (save-input-line stream frame)
+ (setf force-restore-input-state t)
+ (invoke-restart 'acknowledged))))
+ (let ((c (clim:read-gesture :stream stream :peek-p t)))
+ (multiple-value-prog1
+ (cond ((eql c #\/)
+ (handler-case
+ (progn
+ (clim:read-gesture :stream stream)
+ (accept 'command :stream stream :prompt nil))
+ (simple-completion-error (c)
+ #+mcclim
+ (let ((preliminary-line (save-input-line stream frame)))
+ (setf (incomplete-input (current-receiver frame))
+ (subseq preliminary-line 0
+ (search (climi::completion-error-input-so-far c)
+ preliminary-line))
+ bad-input (subseq preliminary-line
+ (search (climi::completion-error-input-so-far c)
+ preliminary-line))
+ force-restore-input-state t))
+ (beep)
+ nil)))
+ (t
+ (list 'com-say (accept 'mumble :history 'mumble :prompt nil :stream stream))))
+ (if force-restore-input-state
+ (setf force-restore-input-state nil)
+ (reset-saved-input)))))))))
+ (command
+ (save-input-line stream frame)
+ object)))
+ (window-clear stream)
+ (when bad-input
+ (format stream "Bad input \"")
+ (with-drawing-options (stream :ink +red3+)
+ (present bad-input 'bad-input :stream stream))
+ (format stream "\".")))))
(defun irc-event-loop (frame connection)
(let ((*application-frame* frame))
--- /project/beirc/cvsroot/beirc/presentations.lisp 2006/03/22 00:31:14 1.13
+++ /project/beirc/cvsroot/beirc/presentations.lisp 2006/04/20 06:39:27 1.14
@@ -8,6 +8,8 @@
(define-presentation-type channel () :inherit-from 'string)
(define-presentation-type hostmask () :inherit-from 'string)
+(define-presentation-type bad-input () :inherit-from 'string)
+
(defun hash-alist (hashtable &aux res)
(maphash (lambda (k v) (push (cons k v) res)) hashtable)
res)
More information about the Beirc-cvs
mailing list