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)