[beirc-cvs] CVS beirc
afuchs
afuchs at common-lisp.net
Mon Mar 6 10:21:28 UTC 2006
Update of /project/beirc/cvsroot/beirc
In directory clnet:/tmp/cvs-serv26302
Modified Files:
application.lisp message-processing.lisp receivers.lisp
Log Message:
Great input saving improvements; Fix browse-url; fix nickname changing
* Apply patch by Stelian Ionescu for browse-url
* Make own-nickname change hook use the right connection.
* Improve read-frame-command to correctly interpret keystroke accels.
* Make read-frame-command save the input line when a command is
invoked when there is input on the line. We use a mcclim-specific
frame-input-context-button-press-handler for the mouse clicking
part of that.
--- /project/beirc/cvsroot/beirc/application.lisp 2006/03/01 09:23:01 1.48
+++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/06 10:21:27 1.49
@@ -30,6 +30,10 @@
(in-package :beirc)
+#+(or)(declaim (optimize (debug 2)
+ (speed 0)
+ (space 0)))
+
;;;; Quick guide:
;;
;; Start with (beirc)
@@ -160,8 +164,6 @@
(defvar *beirc-frame*)
-(defvar *last-input-line* nil)
-
(defun beirc-status-display (*application-frame* *standard-output*)
(with-text-family (t :sans-serif)
(multiple-value-bind (seconds minutes hours) (decode-universal-time (get-universal-time))
@@ -271,8 +273,7 @@
(clim-sys:make-process
(lambda ()
(progv syms vals
- (let* ((*last-input-line* nil)
- (frame (make-application-frame 'beirc))
+ (let* ((frame (make-application-frame 'beirc))
(ticker-process (clim-sys:make-process (lambda () (ticker frame))
:name "Beirc Ticker")))
(setf *beirc-frame* frame)
@@ -406,7 +407,8 @@
(not (eql receiver (current-receiver *application-frame*)))
(= 0
(unseen-messages receiver) (all-unseen-messages receiver)
- (messages-directed-to-me receiver))
+ (messages-directed-to-me receiver)
+ (length (incomplete-input receiver)))
(null (irc:find-channel (connection receiver) (title receiver)))
(> (- (get-universal-time) (last-visited receiver)) *max-query-inactive-time*))
(push receiver receivers-to-close)))
@@ -565,10 +567,10 @@
(irc:nick (current-connection *application-frame*) new-nick))
(define-beirc-command (com-browse-url :name t) ((url 'url :prompt "url"))
- #+sbcl
- (sb-ext:run-program *default-web-browser* `(,url) :wait nil)
- #+openmcl
- (ccl:run-program *default-web-browser* `(,url) :wait nil))
+ (handler-case
+ #+sbcl (sb-ext:run-program *default-web-browser* `(,url) :wait nil)
+ #+openmcl (ccl:run-program *default-web-browser* `(,url) :wait nil)
+ #+sbcl (simple-error (e) (format t "~a" e))))
(define-presentation-to-command-translator nickname-to-ignore-translator
(nickname com-ignore beirc
@@ -800,27 +802,100 @@
(loop for (conn . receiver) in (server-receivers frame)
do (disconnect (connection receiver) frame reason)))
-(defmethod clim:read-frame-command ((frame beirc) &key (stream *standard-input*))
+;;; irc command and mumble reading
+
+(defun save-input-line (stream frame)
+ (let ((buffer (stream-input-buffer stream)))
+ (setf (incomplete-input (current-receiver frame))
+ (with-output-to-string (s)
+ (loop for elt across buffer
+ if (characterp elt)
+ do (write-char elt s))))))
+
+(define-condition invoked-command-by-clicking ()
+ ()
+ (:documentation "A condition that is invoked when the user
+ clicked on a command or on a presentation that invokes a
+ presentation-to-command translator. typically,
+ read-frame-command will handle it and save the input line."))
+
+#+mcclim
+(defmethod frame-input-context-button-press-handler :around ((frame beirc) stream event)
+ "Unportable method for saving the current input buffer in case
+the user invokes a command while typing."
+ (let* ((x (pointer-event-x event))
+ (y (pointer-event-y event))
+ (window (event-sheet event))
+ (presentation (frame-find-innermost-applicable-presentation frame *input-context* stream x y :event event)))
+ (multiple-value-bind (p translator context)
+ (climi::find-innermost-presentation-match *input-context*
+ presentation
+ *application-frame*
+ (event-sheet event)
+ x y
+ event
+ 0
+ nil)
+ (when p
+ (multiple-value-bind (object ptype options)
+ (call-presentation-translator translator
+ p
+ (input-context-type context)
+ *application-frame*
+ event
+ window
+ x y)
+ (declare (ignore object options))
+ (when (and ptype (presentation-subtypep ptype 'command)
+ (boundp '*current-input-stream*) *current-input-stream*)
+ (restart-case (signal 'invoked-command-by-clicking)
+ (acknowledged ())))))))
+ (call-next-method))
+
+(defmethod read-frame-command ((frame beirc) &key (stream *standard-input*))
(multiple-value-prog1
(clim:with-input-editing (stream)
- (when *last-input-line*
- (replace-input stream *last-input-line* :rescan t))
+ (when (incomplete-input (current-receiver frame))
+ (replace-input stream (incomplete-input (current-receiver frame)) :rescan t))
(with-input-context ('command) (object)
- (let ((c (clim:read-gesture :stream stream :peek-p t)))
- (multiple-value-prog1
- (cond ((eql c #\/)
- (clim:read-gesture :stream stream)
- (clim:accept 'clim:command :stream stream :prompt nil))
- (t
- (list 'com-say (accept 'mumble :history 'mumble :prompt nil :stream stream))))
- (setf *last-input-line* nil)))
+ (with-command-table-keystrokes (*accelerator-gestures* (frame-command-table frame))
+ (catch 'keystroke-command
+ (let ((force-restore-input-state nil))
+ (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))
+ (setf (incomplete-input (current-receiver frame)) ""
+ 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)
+ ;; XXX: when accepting commands, the
+ ;; input buffer line will not be saved
+ ;; if the user selects a command or
+ ;; presentation-translated-to-a-command.
+ ;;
+ ;; maybe using *pointer-button-press-handler* could work.
+ (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)
+ (setf (incomplete-input (current-receiver frame)) ""))))))))
(command
- (let ((buffer (stream-input-buffer stream)))
- (when (every 'characterp buffer)
- (setf *last-input-line*
- (with-output-to-string (s)
- (loop for char across buffer
- do (write-char char s))))))
+ (save-input-line stream frame)
object)))
(window-clear stream)))
--- /project/beirc/cvsroot/beirc/message-processing.lisp 2006/03/02 21:46:49 1.3
+++ /project/beirc/cvsroot/beirc/message-processing.lisp 2006/03/06 10:21:28 1.4
@@ -40,11 +40,11 @@
connection *application-frame*)))
(cond
;; we changed our nick
- ((string= (irc:normalize-nickname connection (current-nickname))
+ ((string= (irc:normalize-nickname connection (current-nickname connection))
(irc:normalize-nickname connection (irc:source message)))
(setf (irc:nickname (irc:user (irc:connection message)))
(car (last (irc:arguments message)))
-
+
(irc:normalized-nickname (irc:user (irc:connection message)))
(irc:normalize-nickname connection (car (last (irc:arguments message))))))
(receiver
--- /project/beirc/cvsroot/beirc/receivers.lisp 2006/03/02 21:46:49 1.20
+++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/03/06 10:21:28 1.21
@@ -1,5 +1,7 @@
(in-package :beirc)
-
+#+(or)(declaim (optimize (debug 2)
+ (speed 0)
+ (space 0)))
(defclass receiver ()
((messages :accessor messages :initform nil)
(unseen-messages :accessor unseen-messages :initform 0)
@@ -11,6 +13,7 @@
(focused-nicks :accessor focused-nicks :initform nil)
(title :reader title :initarg :title)
(last-visited :accessor last-visited :initform 0)
+ (incomplete-input :accessor incomplete-input :initform "")
(pane :reader pane)
(tab-pane :accessor tab-pane)))
@@ -82,21 +85,21 @@
(rec (find-receiver name connection frame)))
(if rec
rec
- (let ((*application-frame* frame))
- (let ((receiver (apply 'make-paneless-receiver normalized-name :connection connection
- initargs)))
- (initialize-receiver-with-pane receiver frame
- (with-look-and-feel-realization
- ((frame-manager *application-frame*) *application-frame*)
- (make-clim-application-pane
- :display-function
- (lambda (frame pane)
- (beirc-app-display frame pane receiver))
- :display-time nil
- :min-width 600 :min-height 800
- :incremental-redisplay t)))
- (setf (gethash (list connection normalized-name) (receivers frame)) receiver)
- receiver)))))
+ (let ((*application-frame* frame)
+ (receiver (apply 'make-paneless-receiver normalized-name :connection connection
+ initargs)))
+ (initialize-receiver-with-pane receiver frame
+ (with-look-and-feel-realization
+ ((frame-manager *application-frame*) *application-frame*)
+ (make-clim-application-pane
+ :display-function
+ (lambda (frame pane)
+ (beirc-app-display frame pane receiver))
+ :display-time nil
+ :min-width 600 :min-height 800
+ :incremental-redisplay t)))
+ (setf (gethash (list connection normalized-name) (receivers frame)) receiver)
+ receiver))))
(defun remove-receiver (receiver frame)
(tab-layout:remove-pane (tab-pane receiver)
More information about the Beirc-cvs
mailing list