From afuchs at common-lisp.net Wed Mar 1 09:23:02 2006 From: afuchs at common-lisp.net (afuchs) Date: Wed, 1 Mar 2006 04:23:02 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060301092302.3290A46115@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv15191 Modified Files: application.lisp Log Message: use the connection of the receiver to close, not the *a-f*'s current connection. --- /project/beirc/cvsroot/beirc/application.lisp 2006/02/26 18:41:21 1.47 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/01 09:23:01 1.48 @@ -387,7 +387,7 @@ (define-window-switcher com-window-previous (:prior :control) -1 (constantly t)))) (define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "receiver")) - (let* ((connection (current-connection *application-frame*)) + (let* ((connection (connection receiver)) (channel (irc:find-channel connection (title receiver)))) (cond ((member receiver (server-receivers *application-frame*) :key #'cdr) From afuchs at common-lisp.net Thu Mar 2 21:46:49 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 2 Mar 2006 16:46:49 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060302214649.AA1871B00E@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv21025 Modified Files: message-display.lisp message-processing.lisp receivers.lisp Log Message: Smarter handling of open queries for nick and quit messages. * Quit and Nick messages are now posted to queries with the quitting/nick-changing person, if they are open. * Offer to close a query tab if the user quit. * Also, rename open query tabs when a nick message is received. --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/26 18:41:21 1.37 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/02 21:46:49 1.38 @@ -234,14 +234,17 @@ (defmethod print-message ((message irc:irc-quit-message) receiver) (irc:destructuring-arguments (&optional body) message - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Quit: ") - (present (irc:source message) 'nickname) - (unless (null body) - (format t ": ") - (format-message* body :start-length (+ 8 (length (irc:source message)))))))))) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Quit: ") + (present (irc:source message) 'nickname) + (unless (null body) + (format t ": ") + (format-message* body :start-length (+ 8 (length (irc:source message)))) + (when (string= (title receiver) + (irc:normalize-nickname (connection receiver) (irc:source message))) + (offer-close receiver)))))))) (defun present-as-hostmask (user host) (write-char #\() @@ -313,19 +316,21 @@ ;;; channel management messages +(defun offer-close (receiver) + (format-message* (format nil "To close this tab, click ")) + (present `(com-close ,receiver) 'command)) + (defmethod print-message ((message irc:irc-err_nosuchnick-message) receiver) (formatting-message (t message receiver) ((format t " ")) ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) (irc:destructuring-arguments (me target &rest rest) message (declare (ignore me rest)) - (let* ((close-p (string= (title receiver) - (irc:normalize-nickname (current-connection *application-frame*) - target)))) - (format-message* (format nil "No such nick or channel \"~A\". ~@[To close this tab, click ~]" - target close-p)) - (when close-p - (present `(com-close ,receiver) 'command)))))))) + (format-message* (format nil "No such nick or channel \"~A\". " + target)) + (when (string= (title receiver) + (irc:normalize-nickname (connection receiver) target)) + (offer-close receiver))))))) (defmethod print-message ((message irc:irc-err_chanoprivsneeded-message) receiver) (irc:destructuring-arguments (&last body) message --- /project/beirc/cvsroot/beirc/message-processing.lisp 2006/02/26 18:42:43 1.2 +++ /project/beirc/cvsroot/beirc/message-processing.lisp 2006/03/02 21:46:49 1.3 @@ -30,15 +30,25 @@ ;;; Message preprocessing (defmethod preprocess-message ((connection beirc-connection) (message irc:irc-nick-message)) - "Change the connection's local user's nickname if it is the -local user that changed its nickname." - (when (string= (irc:normalize-nickname connection (current-nickname)) - (irc:normalize-nickname connection (irc:source message))) - (setf (irc:nickname (irc:user (irc:connection message))) - (car (last (irc:arguments message))) + "Handle various Nickname-change message cases: + + * change the connection's local user's nickname if it is the + local user that changed its nickname. + * rename queries that are open so that the nickname message gets + posted there, too." + (let ((receiver (find-receiver (irc:normalize-nickname connection (irc:source message)) + connection *application-frame*))) + (cond + ;; we changed our nick + ((string= (irc:normalize-nickname connection (current-nickname)) + (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))))))) + (irc:normalized-nickname (irc:user (irc:connection message))) + (irc:normalize-nickname connection (car (last (irc:arguments message)))))) + (receiver + (rename-query-receiver receiver (car (last (irc:arguments message)))))))) (defmethod preprocess-message (connection message) nil) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/25 23:28:11 1.19 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/03/02 21:46:49 1.20 @@ -60,6 +60,19 @@ (change-space-requirements pane))) (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver)) +(defun rename-query-receiver (receiver new-name) + (let ((old-title (irc:normalize-nickname (connection receiver) + (title receiver))) + (normalized-name (irc:normalize-nickname (connection receiver) + new-name))) + (with-slots (title query) receiver + (setf title new-name + query new-name + (tab-layout::tab-pane-title (tab-pane receiver)) new-name) + (remhash (list (connection receiver) old-title) (receivers *application-frame*)) + (setf (gethash (list (connection receiver) normalized-name) (receivers *application-frame*)) + receiver)))) + (defun find-receiver (name connection frame) (gethash (list connection (irc:normalize-channel-name connection name)) (receivers frame))) @@ -138,13 +151,20 @@ `(defmethod receiver-for-message ((message ,message-type) frame) (remove nil (mapcar (lambda (channel) - (find-receiver (irc:name channel) (irc:connection message) frame)) - (let ((user (irc:find-user (current-connection frame) + (find-receiver channel (irc:connection message) frame)) + (let ((user (irc:find-user (irc:connection message) (irc:source message)))) (when user - (irc:channels user)))))))) - (define-global-message-receiver-lookup irc:irc-quit-message) - (define-global-message-receiver-lookup irc:irc-nick-message)) + `(,@(mapcar (lambda (chan) + (irc:normalize-channel-name (irc:connection message) + (irc:name chan))) + (irc:channels user)) + ,(irc:normalize-nickname (irc:connection message) + (if (typep message 'irc:irc-quit-message) + (irc:source message) + (car (last (irc:arguments message))))))))))))) + (define-global-message-receiver-lookup irc:irc-quit-message) + (define-global-message-receiver-lookup irc:irc-nick-message)) (macrolet ((define-nth-arg-message-receiver-lookup (&rest clauses) "Defines receiver-for-message methods that return From afuchs at common-lisp.net Mon Mar 6 10:21:28 2006 From: afuchs at common-lisp.net (afuchs) Date: Mon, 6 Mar 2006 05:21:28 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060306102128.2B98F2B006@common-lisp.net> 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) From afuchs at common-lisp.net Mon Mar 6 10:25:00 2006 From: afuchs at common-lisp.net (afuchs) Date: Mon, 6 Mar 2006 05:25:00 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060306102500.42CDD2B006@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv26336 Modified Files: application.lisp Log Message: fix frame-input-context-button-press-handler for non-presentation clicks. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/06 10:21:27 1.49 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/06 10:25:00 1.50 @@ -827,29 +827,30 @@ (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 ()))))))) + (when presentation + (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*)) From afuchs at common-lisp.net Mon Mar 6 17:41:32 2006 From: afuchs at common-lisp.net (afuchs) Date: Mon, 6 Mar 2006 12:41:32 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060306174132.ABFFE7A000@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv13160 Modified Files: application.lisp Log Message: oops. Input saving won't work without a receiver object. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/06 10:25:00 1.50 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/06 17:41:32 1.51 @@ -805,12 +805,13 @@ ;;; 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)))))) + (when (current-receiver 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 () () @@ -856,45 +857,48 @@ (defmethod read-frame-command ((frame beirc) &key (stream *standard-input*)) (multiple-value-prog1 (clim:with-input-editing (stream) - (when (incomplete-input (current-receiver frame)) + (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)) - (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)) "")))))))) + (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) + ;; 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) + (reset-saved-input))))))))) (command (save-input-line stream frame) object))) From afuchs at common-lisp.net Mon Mar 6 17:53:59 2006 From: afuchs at common-lisp.net (afuchs) Date: Mon, 6 Mar 2006 12:53:59 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060306175359.0B90A16003@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv15579 Modified Files: application.lisp Log Message: oops, remove the misleading comment in read-frame-command too. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/06 17:41:32 1.51 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/06 17:53:58 1.52 @@ -887,12 +887,6 @@ (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)))) From afuchs at common-lisp.net Sun Mar 12 09:48:57 2006 From: afuchs at common-lisp.net (afuchs) Date: Sun, 12 Mar 2006 04:48:57 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060312094857.C51A4431C1@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv22818 Modified Files: application.lisp beirc.asd message-display.lisp receivers.lisp Added Files: events.lisp Log Message: Speedup redisplay; time display; factor out events; robustify pane creation. * The foo-event handler now calls redisplay only if it is invoked for the last foo-event for the current event's receiver. This speeds up redisplay considerably if many messages come in simultaneously. * Added time/date display for some message types * Moved event definitions to events.lisp * Pane creation doesn't happen in the irc listener thread anymore, but is triggered in the ui thread via a new-sheet-event. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/06 17:53:58 1.52 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/12 09:48:57 1.53 @@ -75,6 +75,7 @@ (define-application-frame beirc (redisplay-frame-mixin standard-application-frame) ((connection-processes :initform nil :accessor connection-processes) + (ui-process :initform (current-process) :accessor ui-process) (ignored-nicks :initform nil) (receivers :initform (make-hash-table :test #'equal) :accessor receivers) (server-receivers :initform nil :reader server-receivers) @@ -168,7 +169,7 @@ (with-text-family (t :sans-serif) (multiple-value-bind (seconds minutes hours) (decode-universal-time (get-universal-time)) seconds - (format t "~2,'0D:~2,'0D ~A~:[~;(away)~] on ~A~@[ speaking to ~A~]~100T~D messages" + (format t "~2,'0D:~2,'0D ~A~:[~;(away)~] ~@[on ~A~]~@[ speaking to ~A~]~100T~D messages" hours minutes (current-nickname) (away-status *application-frame* (current-connection *application-frame*)) @@ -199,23 +200,6 @@ ;; "~:@>") ;; prefix))) - -;;; Here comes the trick: - -;;; Although I would pretty much prefer an implementation of CLIM -;;; which is thread safe, I figure we better go through the central -;;; event loop. We define a new event class, subclass of -;;; WINDOW-MANAGER-EVENT, and when ever we want to update the display -;;; we send it to the frame. - -(defclass foo-event (clim:window-manager-event) - ((sheet :initarg :sheet :reader event-sheet) - (receiver :initarg :receiver :reader receiver))) - -;;for updating the time display, triggered from TICKER -(defclass bar-event (clim:window-manager-event) - ((sheet :initarg :sheet :reader event-sheet))) - ;;; (defun pane-scrolled-to-bottom-p (pane) @@ -245,14 +229,25 @@ (redraw-receiver receiver)) (receivers *application-frame*)))) +;;; event handling methods + +(defmethod handle-event ((frame beirc) (event new-sheet-event)) + (funcall (sheet-creation-closure event) frame)) + (defmethod handle-event ((frame beirc) (event foo-event)) ;; Hack: ;; Figure out if we are scrolled to the bottom. (let* ((receiver (receiver event)) - (pane (actual-application-pane (pane receiver)))) + (pane (actual-application-pane (pane receiver))) + (next-event (event-peek (frame-top-level-sheet frame)))) (let ((btmp (pane-scrolled-to-bottom-p pane))) - (setf (pane-needs-redisplay pane) t) - (redisplay-frame-panes frame) + (update-drawing-options receiver) + ;; delay redisplay until this is the last event in the queue + ;; (for this event's receiver). + (unless (and (typep next-event 'foo-event) + (eql (receiver next-event) receiver)) + (setf (pane-needs-redisplay pane) t) + (redisplay-frame-panes frame)) (when btmp (scroll-pane-to-bottom pane))) (medium-force-output (sheet-medium pane)) ;### )) @@ -299,10 +294,8 @@ (when (message-directed-to-me-p message) (incf (messages-directed-to-me receiver))) (incf (all-unseen-messages receiver))) - (update-drawing-options receiver) - (clim-internals::event-queue-prepend - (climi::frame-event-queue frame) - (make-instance 'foo-event :sheet frame :receiver receiver)) + (queue-event (frame-top-level-sheet frame) + (make-instance 'foo-event :sheet frame :receiver receiver)) nil) (defun post-message (frame message) @@ -776,6 +769,7 @@ (tab-layout:remove-pane (find-pane-named frame 'server) (find-pane-named frame 'query))) (setf (server-receiver frame connection) server-receiver) + (setf (ui-process *application-frame*) (current-process)) (setf (connection-process *application-frame* connection) (clim-sys:make-process #'(lambda () (restart-case --- /project/beirc/cvsroot/beirc/beirc.asd 2006/02/26 18:41:21 1.6 +++ /project/beirc/cvsroot/beirc/beirc.asd 2006/03/12 09:48:57 1.7 @@ -9,8 +9,9 @@ :depends-on (:mcclim :cl-irc :split-sequence :tab-layout) :components ((:file "package") (:file "variables" :depends-on ("package")) - (:file "receivers" :depends-on ("package" "variables")) + (:file "events" :depends-on ("package")) + (:file "receivers" :depends-on ("package" "variables" "events")) (:file "presentations" :depends-on ("package" "variables" "receivers")) (:file "message-display" :depends-on ("package" "variables" "presentations")) - (:file "application" :depends-on ("package" "variables" "presentations" "receivers")) + (:file "application" :depends-on ("package" "variables" "presentations" "events" "receivers")) (:file "message-processing" :depends-on ("package" "variables" "receivers" "application")))) \ No newline at end of file --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/02 21:46:49 1.38 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/12 09:48:57 1.39 @@ -224,6 +224,8 @@ (irc:irc-rpl_unaway-message)))) (defmethod print-message (message receiver) + ;; default message if we don't know how to render a message. + #+(or) (break "~S" message) ; uncomment to debug (irc:destructuring-arguments (&whole args &last body) message (formatting-message (t message receiver) ((format t "!!! ~A" (irc:source message))) @@ -302,7 +304,7 @@ ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (present nickname 'nickname) (format-message* (format nil " is away: ~A" away-msg) - :start-length (length (second (irc:arguments message))))))))) + :start-length (length nickname))))))) (defmethod print-message ((message irc:irc-rpl_whoisidentified-message) receiver) (irc:destructuring-arguments (me nickname body) message @@ -312,7 +314,29 @@ ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (present nickname 'nickname) (write-char #\Space) - (format-message* body :start-length (length (second (irc:arguments message))))))))) + (format-message* body :start-length (length nickname))))))) + +(defun unix-epoch-to-universal-time (epoch-time) + (+ epoch-time 2208988800 ; seconds between 1970-01-01 0:00 and 1900-01-01 0:00 + )) + +(defun format-unix-epoch (unix-epoch) + (multiple-value-bind (second minute hour date month year) + (decode-universal-time (unix-epoch-to-universal-time unix-epoch)) + (format nil "~4,1,0,'0 at A-~2,1,0,'0 at A-~2,1,0,'0 at A, ~2,1,0,'0 at A:~2,1,0,'0 at A:~2,1,0,'0 at A" + year month date hour minute second))) + +(defmethod print-message ((message irc:irc-rpl_whoisidle-message) receiver) + (irc:destructuring-arguments (me nickname idle signon &rest rest) message + (declare (ignore me rest)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present nickname 'nickname) + (write-char #\Space) + (format-message* (format nil "was idle ~A seconds, signed on: ~A" + idle (format-unix-epoch (parse-integer signon))) + :start-length (length nickname))))))) ;;; channel management messages @@ -343,18 +367,25 @@ (formatting-message (t message receiver) ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (if (null sender) - (format-message* (format nil "Topic for ~A: ~A" channel topic)) - (progn - (present sender 'nickname) - (format-message* (format nil " set the topic for ~A to ~A" channel topic)))))))) + (cond + ((and (null sender) (null topic)) + (format-message* (format nil "No topic for ~A" channel))) + ((null sender) + (format-message* (format nil "Topic for ~A: ~A" channel topic))) + ((null topic) + (present sender 'nickname) + (format-message* (format nil " cleared the topic of ~A" channel))) + (t + (present sender 'nickname) + (format-message* (format nil " set the topic for ~A to ~A" channel topic)))))))) (defmethod print-message ((message irc:irc-topic-message) receiver) (irc:destructuring-arguments (channel &last topic) message (print-topic receiver message (irc:source message) channel topic))) (defmethod print-message ((message irc:irc-rpl_topic-message) receiver) - (irc:destructuring-arguments (channel &last topic) message + (irc:destructuring-arguments (target channel &optional topic) message + (declare (ignore target)) (print-topic receiver message nil channel topic))) (defmethod print-message ((message irc:irc-rpl_topicwhotime-message) receiver) @@ -362,10 +393,9 @@ ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (irc:destructuring-arguments (me channel who time) message - (declare (ignore me - time ; TODO: no date display for now. - )) - (format-message* (format nil "~A topic set by ~A" channel who))))))) + (declare (ignore me)) + (format-message* (format nil "~A topic set by ~A on ~A" channel who + (format-unix-epoch (parse-integer time))))))))) (defmethod print-message ((message irc:irc-rpl_namreply-message) receiver) (irc:destructuring-arguments (me privacy channel &last nicks) message --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/03/06 10:21:28 1.21 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/03/12 09:48:57 1.22 @@ -85,19 +85,24 @@ (rec (find-receiver name connection frame))) (if rec rec - (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))) + (let* ((*application-frame* frame) + (receiver (apply 'make-paneless-receiver normalized-name :connection connection + initargs)) + (creator (lambda (frame) + (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))) + (update-drawing-options receiver)))) + (if (equal (current-process) (ui-process frame)) + (funcall creator frame) + (queue-event (frame-top-level-sheet frame) (make-instance 'new-sheet-event :sheet frame :creator creator))) (setf (gethash (list connection normalized-name) (receivers frame)) receiver) receiver)))) @@ -209,18 +214,21 @@ (declare (ignore modes args)) (intern-receiver channel (irc:connection message) frame :channel channel))))) -(macrolet ((define-current-receiver-message-types (&rest mtypes) +(macrolet ((define-current-receiver-or-server-message-types (&rest mtypes) `(progn ,@(loop for mtype in mtypes collect `(defmethod receiver-for-message ((message ,mtype) frame) - (current-receiver frame)))))) - (define-current-receiver-message-types + (if (equal (connection (current-receiver frame)) (irc:connection message)) + (current-receiver frame) + (server-receiver frame (irc:connection message)))))))) + (define-current-receiver-or-server-message-types irc:irc-rpl_whoisuser-message irc:irc-rpl_whoischannels-message - irc:irc-rpl_whoisserver-message - irc:irc-rpl_whoisidentified-message - irc:irc-rpl_away-message - irc:irc-err_nosuchnick-message)) + irc:irc-rpl_whoisserver-message + irc:irc-rpl_whoisidentified-message + irc:irc-rpl_whoisidle-message + irc:irc-rpl_away-message + irc:irc-err_nosuchnick-message)) (macrolet ((define-ignore-message-types (&rest mtypes) `(progn @@ -270,10 +278,12 @@ (define-delegate current-focused-nicks focused-nicks t)) (defun update-drawing-options (receiver) - (set-drawing-options-for-pane-in-tab-layout (pane receiver) - `(:ink ,(cond ((> (messages-directed-to-me receiver) 0) +green+) - ((> (unseen-messages receiver) 0) +red+) - (t +black+))))) + (when (and (slot-boundp receiver 'pane) (sheetp (pane receiver)) + (find-in-tab-panes-list (pane receiver) 'tab-layout-pane)) + (set-drawing-options-for-pane-in-tab-layout (pane receiver) + `(:ink ,(cond ((> (messages-directed-to-me receiver) 0) +green+) + ((> (unseen-messages receiver) 0) +red+) + (t +black+)))))) (defmethod switch-to-pane :after ((pane sheet) (parent (eql 'tab-layout-pane))) (let ((my-tab-layout-pane (find-pane-named *application-frame* 'query))) --- /project/beirc/cvsroot/beirc/events.lisp 2006/03/12 09:48:57 NONE +++ /project/beirc/cvsroot/beirc/events.lisp 2006/03/12 09:48:57 1.1 (in-package :beirc) ;;; Here comes the trick: ;;; Although I would pretty much prefer an implementation of CLIM ;;; which is thread safe, I figure we better go through the central ;;; event loop. We define a new event class, subclass of ;;; WINDOW-MANAGER-EVENT, and when ever we want to update the display ;;; we send it to the frame. (defclass foo-event (clim:window-manager-event) ((sheet :initarg :sheet :reader event-sheet) (receiver :initarg :receiver :reader receiver))) ;;for updating the time display, triggered from TICKER (defclass bar-event (clim:window-manager-event) ((sheet :initarg :sheet :reader event-sheet))) (defclass new-sheet-event (clim:window-manager-event) ((sheet :initarg :sheet :reader event-sheet) (closure :initarg :creator :reader sheet-creation-closure) (receiver :initarg :receiver :reader receiver))) From afuchs at common-lisp.net Sun Mar 12 10:23:46 2006 From: afuchs at common-lisp.net (afuchs) Date: Sun, 12 Mar 2006 05:23:46 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060312102346.413135200B@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv1571 Added Files: .cvsignore Log Message: Add a .cvsignore file for .fasl and ,* files --- /project/beirc/cvsroot/beirc/.cvsignore 2006/03/12 10:23:46 NONE +++ /project/beirc/cvsroot/beirc/.cvsignore 2006/03/12 10:23:46 1.1 *.fasl ,* From afuchs at common-lisp.net Thu Mar 16 00:01:46 2006 From: afuchs at common-lisp.net (afuchs) Date: Wed, 15 Mar 2006 19:01:46 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060316000146.98B7070213@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv17189 Modified Files: application.lisp receivers.lisp Log Message: Add /{Previous,Next} Highlighted Message commands * commands are bound to shift-prior and shift-next respectively. * also fix the nick->hostmask translator to generate hostmask only when the user has a known hostname, otherwise generate a nickname mask --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/12 09:48:57 1.53 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 00:01:46 1.54 @@ -294,6 +294,14 @@ (when (message-directed-to-me-p message) (incf (messages-directed-to-me receiver))) (incf (all-unseen-messages receiver))) + (when (and (slot-boundp receiver 'pane) (pane receiver)) + (let* ((pane (actual-application-pane (pane receiver))) + (current-insert-position (bounding-rectangle-height pane))) + (when (and (not (eql current-insert-position + (first (positions-mentioning-user receiver)))) + (message-directed-to-me-p message)) + (push current-insert-position + (positions-mentioning-user receiver))))) (queue-event (frame-top-level-sheet frame) (make-instance 'foo-event :sheet frame :receiver receiver)) nil) @@ -392,6 +400,30 @@ (irc:part connection channel)))) (remove-receiver receiver *application-frame*)) +(macrolet ((define-highlighted-message-jumper (com-name keystroke next-pos-form fallback-position) + `(define-beirc-command (,com-name :name t :keystroke ,keystroke) () + (let* ((pane (actual-application-pane (pane (current-receiver *application-frame*)))) + (next-y-position ,next-pos-form) + (bottom (max 0 (- (bounding-rectangle-height pane) + (bounding-rectangle-height (sheet-parent pane))))) + (top 0)) + (scroll-extent pane 0 (if next-y-position + (min next-y-position bottom) + (progn + (beep) + (funcall ,fallback-position bottom top)))))))) + (define-highlighted-message-jumper com-previous-highlighted-message (:prior :shift) + (find-if (lambda (position) + (< position (bounding-rectangle-min-y (pane-viewport-region pane)))) + (positions-mentioning-user (current-receiver *application-frame*))) + (lambda (bottom top) (declare (ignore bottom)) top)) + (define-highlighted-message-jumper com-next-highlighted-message (:next :shift) + (loop for (this prev . rest) on (positions-mentioning-user (current-receiver *application-frame*)) + until (null prev) + if (<= prev (bounding-rectangle-min-y (pane-viewport-region pane)) this) + do (return this)) + (lambda (bottom top) (declare (ignore top)) bottom))) + (define-beirc-command (com-remove-inactive-queries :name t) () (let ((receivers-to-close nil)) (maphash (lambda (name receiver) @@ -734,7 +766,10 @@ (declare (ignore object)) (presentation-subtypep context-type 'hostmask))) (object) - (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object)))) + (let ((hostname (irc:hostname (irc:find-user (current-connection *application-frame*) object)))) + (if (zerop (length hostname)) + (format nil "~A!*@*" object) + (format nil "*!*@~A" hostname)))) (define-beirc-command (com-join :name t) ((channel 'channel :prompt "channel")) (raise-receiver (intern-receiver channel (current-connection *application-frame*) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/03/12 09:48:57 1.22 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/03/16 00:01:46 1.23 @@ -14,6 +14,7 @@ (title :reader title :initarg :title) (last-visited :accessor last-visited :initform 0) (incomplete-input :accessor incomplete-input :initform "") + (positions-mentioning-user :accessor positions-mentioning-user :initform nil) (pane :reader pane) (tab-pane :accessor tab-pane))) From afuchs at common-lisp.net Thu Mar 16 00:12:05 2006 From: afuchs at common-lisp.net (afuchs) Date: Wed, 15 Mar 2006 19:12:05 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060316001205.6FEA43125@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv17394 Modified Files: application.lisp Log Message: Fix com-browse-url for ACL compatibility. Patch by Richard P. Goldman. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 00:01:46 1.54 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 00:12:05 1.55 @@ -593,8 +593,17 @@ (define-beirc-command (com-browse-url :name t) ((url 'url :prompt "url")) (handler-case + ;; this is probably not ENTIRELY The Right Thing for Allegro. I + ;; think for Allegro it would be handy to keep the process-id + ;; around so that we can call the reap-os-subprocesses + ;; function... Not sure how to do this. [2006/03/14:rpg] + ;; actually, this is true for all of these invocations. doesn't + ;; bite us in sbcl, though. [2006/03/15:asf] + #+allegro (excl:run-shell-command (format nil "~A ~A" *default-web-browser* url) :wait nil) #+sbcl (sb-ext:run-program *default-web-browser* `(,url) :wait nil) #+openmcl (ccl:run-program *default-web-browser* `(,url) :wait nil) + #-(or sbcl openmcl allegro) (progn (format *debug-io* "Can't figure out how to browse to url ~A~%" url) + (beep)) #+sbcl (simple-error (e) (format t "~a" e)))) (define-presentation-to-command-translator nickname-to-ignore-translator From afuchs at common-lisp.net Thu Mar 16 09:39:08 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 16 Mar 2006 04:39:08 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060316093908.870DE5200B@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv19171 Modified Files: application.lisp Log Message: Add /{Next,Previous} Page and /Top and /Bottom commands: * bound to PgDown, PgUp, Ctrl-Home and Ctrl-End. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 00:12:05 1.55 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 09:39:08 1.56 @@ -400,29 +400,46 @@ (irc:part connection channel)))) (remove-receiver receiver *application-frame*)) -(macrolet ((define-highlighted-message-jumper (com-name keystroke next-pos-form fallback-position) +(macrolet ((define-scroller-command ((com-name keystroke) (top-var bot-var) next-pos-form &optional fallback-position) `(define-beirc-command (,com-name :name t :keystroke ,keystroke) () (let* ((pane (actual-application-pane (pane (current-receiver *application-frame*)))) - (next-y-position ,next-pos-form) - (bottom (max 0 (- (bounding-rectangle-height pane) - (bounding-rectangle-height (sheet-parent pane))))) - (top 0)) - (scroll-extent pane 0 (if next-y-position - (min next-y-position bottom) - (progn - (beep) - (funcall ,fallback-position bottom top)))))))) - (define-highlighted-message-jumper com-previous-highlighted-message (:prior :shift) + (,bot-var (max 0 (- (bounding-rectangle-height pane) + (bounding-rectangle-height (sheet-parent pane))))) + (,top-var 0) + (next-y-position ,next-pos-form)) + (declare (ignorable ,top-var ,bot-var)) + (scroll-extent pane 0 ,(if fallback-position + `(if next-y-position + (max 0 (min next-y-position bottom)) + (progn + (beep) + ,fallback-position)) + `(max 0 (min next-y-position bottom)))))))) + (define-scroller-command (com-previous-highlighted-message (:prior :shift)) (top bottom) (find-if (lambda (position) (< position (bounding-rectangle-min-y (pane-viewport-region pane)))) (positions-mentioning-user (current-receiver *application-frame*))) - (lambda (bottom top) (declare (ignore bottom)) top)) - (define-highlighted-message-jumper com-next-highlighted-message (:next :shift) + top) + (define-scroller-command (com-next-highlighted-message (:next :shift)) (top bottom) (loop for (this prev . rest) on (positions-mentioning-user (current-receiver *application-frame*)) until (null prev) if (<= prev (bounding-rectangle-min-y (pane-viewport-region pane)) this) do (return this)) - (lambda (bottom top) (declare (ignore top)) bottom))) + bottom) + (define-scroller-command (com-previous-page (:prior)) (top bottom) + (let* ((pane (actual-application-pane (pane (current-receiver *application-frame*)))) + (pane-min-y (rectangle-min-y (pane-viewport-region pane))) + (scroll-by (* (rectangle-height (pane-viewport-region pane)) 19/20))) + (- pane-min-y scroll-by))) + (define-scroller-command (com-next-page (:next)) (top bottom) + (let* ((pane (actual-application-pane (pane (current-receiver *application-frame*)))) + (pane-min-y (rectangle-min-y (pane-viewport-region pane))) + (scroll-by (* (rectangle-height (pane-viewport-region pane)) 19/20))) + (+ pane-min-y scroll-by))) + (define-scroller-command (com-top (:home :control)) (top bottom) + top) + (define-scroller-command (com-bottom (:end :control)) (top bottom) + bottom)) (define-beirc-command (com-remove-inactive-queries :name t) () (let ((receivers-to-close nil)) From afuchs at common-lisp.net Thu Mar 16 19:11:19 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 16 Mar 2006 14:11:19 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060316191119.B188563020@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv778 Modified Files: application.lisp Log Message: remove :gesture :menu to make the right-click presentation menu work again. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 09:39:08 1.56 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 19:11:19 1.57 @@ -625,7 +625,6 @@ (define-presentation-to-command-translator nickname-to-ignore-translator (nickname com-ignore beirc - :gesture :menu :menu t :documentation "Ignore this user" :pointer-documentation "Ignore this user" @@ -638,7 +637,6 @@ (define-presentation-to-command-translator nickname-to-unignore-translator (nickname com-unignore beirc - :gesture :menu :menu t :documentation "Unignore this user" :pointer-documentation "Unignore this user" @@ -650,7 +648,6 @@ (define-presentation-to-command-translator nickname-to-focus-translator (nickname com-focus beirc - :gesture :menu :menu t :documentation "Focus this user" :pointer-documentation "Focus this user" @@ -662,7 +659,6 @@ (define-presentation-to-command-translator nickname-to-unfocus-translator (nickname com-unfocus beirc - :gesture :menu :menu t :documentation "Unfocus this user" :pointer-documentation "Unfocus this user" @@ -674,7 +670,6 @@ (define-presentation-to-command-translator nickname-to-query-translator (nickname com-query beirc - :gesture :menu :menu t :documentation "Query this user" :pointer-documentation "Query this user") @@ -683,7 +678,6 @@ (define-presentation-to-command-translator nickname-to-kick-translator (nickname com-kick beirc - :gesture :menu :menu t :documentation "Kick this user" :pointer-documentation "Kick this user") @@ -696,7 +690,6 @@ (define-presentation-to-command-translator nickname-to-ban-nick-translator (nickname com-ban-nick beirc - :gesture :menu :menu t :documentation "Ban this user's nickname" :pointer-documentation "Ban this user's nickname") @@ -705,7 +698,6 @@ (define-presentation-to-command-translator hostmask-to-ban-translator (hostmask com-ban-hostmask beirc - :gesture :menu :menu t :documentation "Ban this hostmask" :pointer-documentation "Ban this hostmask") @@ -714,7 +706,6 @@ (define-presentation-to-command-translator hostmask-to-unban-translator (hostmask com-unban-hostmask beirc - :gesture :menu :menu t :documentation "Unban this hostmask" :pointer-documentation "Unban this hostmask") @@ -723,7 +714,6 @@ (define-presentation-to-command-translator nickname-to-ban-hostmask-translator (nickname com-ban-hostmask beirc - :gesture :menu :menu t :documentation "Ban this user's hostmask" :pointer-documentation "Ban this user's hostmask") From afuchs at common-lisp.net Thu Mar 16 19:18:38 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 16 Mar 2006 14:18:38 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060316191838.DD3EC650A2@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv2267 Modified Files: application.lisp Log Message: Increase :priority of the translators we want to use on gestures. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 19:11:19 1.57 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 19:18:38 1.58 @@ -725,7 +725,8 @@ :gesture :select :menu t :documentation "Perform WHOIS query on user" - :pointer-documentation "Perform WHOIS query on user") + :pointer-documentation "Perform WHOIS query on user" + :priority 10) (object) (list object)) @@ -734,7 +735,8 @@ :gesture :describe :menu t :documentation "Join this channel" - :pointer-documentation "Join this channel") + :pointer-documentation "Join this channel" + :priority 10) (object) (list object)) From afuchs at common-lisp.net Thu Mar 16 19:29:10 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 16 Mar 2006 14:29:10 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060316192910.B06C9640C0@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv2721 Modified Files: application.lisp Log Message: Use explicit :gesture nil on menu-only presentation translators. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 19:18:38 1.58 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 19:29:10 1.59 @@ -626,6 +626,7 @@ (define-presentation-to-command-translator nickname-to-ignore-translator (nickname com-ignore beirc :menu t + :gesture nil :documentation "Ignore this user" :pointer-documentation "Ignore this user" :tester ((object) @@ -638,6 +639,7 @@ (define-presentation-to-command-translator nickname-to-unignore-translator (nickname com-unignore beirc :menu t + :gesture nil :documentation "Unignore this user" :pointer-documentation "Unignore this user" :tester ((object) @@ -649,6 +651,7 @@ (define-presentation-to-command-translator nickname-to-focus-translator (nickname com-focus beirc :menu t + :gesture nil :documentation "Focus this user" :pointer-documentation "Focus this user" :tester ((object) @@ -660,6 +663,7 @@ (define-presentation-to-command-translator nickname-to-unfocus-translator (nickname com-unfocus beirc :menu t + :gesture nil :documentation "Unfocus this user" :pointer-documentation "Unfocus this user" :tester ((object) @@ -671,6 +675,7 @@ (define-presentation-to-command-translator nickname-to-query-translator (nickname com-query beirc :menu t + :gesture nil :documentation "Query this user" :pointer-documentation "Query this user") (object) @@ -679,6 +684,7 @@ (define-presentation-to-command-translator nickname-to-kick-translator (nickname com-kick beirc :menu t + :gesture nil :documentation "Kick this user" :pointer-documentation "Kick this user") (object) @@ -691,6 +697,7 @@ (define-presentation-to-command-translator nickname-to-ban-nick-translator (nickname com-ban-nick beirc :menu t + :gesture nil :documentation "Ban this user's nickname" :pointer-documentation "Ban this user's nickname") (object) @@ -699,6 +706,7 @@ (define-presentation-to-command-translator hostmask-to-ban-translator (hostmask com-ban-hostmask beirc :menu t + :gesture nil :documentation "Ban this hostmask" :pointer-documentation "Ban this hostmask") (object) @@ -707,6 +715,7 @@ (define-presentation-to-command-translator hostmask-to-unban-translator (hostmask com-unban-hostmask beirc :menu t + :gesture nil :documentation "Unban this hostmask" :pointer-documentation "Unban this hostmask") (object) @@ -715,6 +724,7 @@ (define-presentation-to-command-translator nickname-to-ban-hostmask-translator (nickname com-ban-hostmask beirc :menu t + :gesture nil :documentation "Ban this user's hostmask" :pointer-documentation "Ban this user's hostmask") (object) From afuchs at common-lisp.net Thu Mar 16 20:22:57 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 16 Mar 2006 15:22:57 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060316202257.75D2772080@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv10954 Modified Files: application.lisp Log Message: Do nothing if connecting to a server/nick that we're already connected to. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 19:29:10 1.59 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 20:22:57 1.60 @@ -133,6 +133,14 @@ &optional (connection (current-connection *application-frame*))) (cdr (assoc connection (server-receivers frame) :test #'connection=))) +(defmethod server-receiver-from-args ((frame beirc) server-name port nickname) + (loop for (connection . receiver) in (server-receivers frame) + if (and (equal (irc:nickname (irc:user connection)) nickname) + (equal (irc:server-name connection) server-name) + ;; TODO: no port. + ) + do (return receiver))) + (defmethod (setf server-receiver) (newval (frame beirc) &optional (connection (current-connection *application-frame*))) (pushnew (cons connection newval) (slot-value frame 'server-receivers) @@ -817,33 +825,34 @@ (pass 'string :prompt "Password" :default nil) (port 'number :prompt "Port" :default irc::*default-irc-server-port*)) (let ((success nil)) - (let* ((frame *application-frame*) - (connection (apply #'irc:connect - :nickname nick :server server :connection-type 'beirc-connection :port port - (if (null pass) - nil - `(:password ,pass)))) - (server-receiver (intern-receiver (format nil "~A on ~A:~A" nick server port) connection frame))) - (unwind-protect - (progn - (setf (irc:client-stream connection) (make-broadcast-stream)) - (when (tab-layout:find-in-tab-panes-list (find-pane-named frame 'server) - (find-pane-named frame 'query)) - (tab-layout:remove-pane (find-pane-named frame 'server) - (find-pane-named frame 'query))) - (setf (server-receiver frame connection) server-receiver) - (setf (ui-process *application-frame*) (current-process)) - (setf (connection-process *application-frame* connection) - (clim-sys:make-process #'(lambda () - (restart-case - (irc-event-loop frame connection) - (disconnect () - :report "Terminate this connection" - (disconnect connection frame "Client Disconnect")))) - :name "IRC Message Muffling Loop")) - (setf success t)) - (unless success - (disconnect connection frame "Client error.")))))) + (or (server-receiver-from-args *application-frame* server port nick) + (let* ((frame *application-frame*) + (connection (apply #'irc:connect + :nickname nick :server server :connection-type 'beirc-connection :port port + (if (null pass) + nil + `(:password ,pass)))) + (server-receiver (intern-receiver (format nil "~A on ~A:~A" nick server port) connection frame))) + (unwind-protect + (progn + (setf (irc:client-stream connection) (make-broadcast-stream)) + (when (tab-layout:find-in-tab-panes-list (find-pane-named frame 'server) + (find-pane-named frame 'query)) + (tab-layout:remove-pane (find-pane-named frame 'server) + (find-pane-named frame 'query))) + (setf (server-receiver frame connection) server-receiver) + (setf (ui-process *application-frame*) (current-process)) + (setf (connection-process *application-frame* connection) + (clim-sys:make-process #'(lambda () + (restart-case + (irc-event-loop frame connection) + (disconnect () + :report "Terminate this connection" + (disconnect connection frame "Client Disconnect")))) + :name "IRC Message Muffling Loop")) + (setf success t)) + (unless success + (disconnect connection frame "Client error."))))))) (defun disconnect (connection frame reason) (let ((*application-frame* frame)) From afuchs at common-lisp.net Thu Mar 16 20:32:05 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 16 Mar 2006 15:32:05 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060316203205.495D35083@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv13300 Modified Files: application.lisp message-processing.lisp Log Message: Fixes by Robert P. Goldman: rename "receiver" to "tab", choose a different nickname on connect. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 20:22:57 1.60 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 20:32:05 1.61 @@ -116,11 +116,12 @@ (20 ;<-- Sigh! Bitrot! status-bar))))) -(defun receiver-from-tab-pane (tab-pane) - (gethash tab-pane (tab-panes-to-receivers *application-frame*))) +;;; addition of optional argument allows debugging from outside the frame process. [2006/03/16:rpg] +(defun receiver-from-tab-pane (tab-pane &optional (frame *application-frame*)) + (gethash tab-pane (tab-panes-to-receivers frame))) (defmethod current-receiver ((frame beirc)) - (let ((receiver (receiver-from-tab-pane (enabled-pane (find-pane-named frame 'query))))) + (let ((receiver (receiver-from-tab-pane (enabled-pane (find-pane-named frame 'query)) frame))) (if (typep receiver 'receiver) receiver nil))) @@ -283,7 +284,10 @@ (load-user-init-file) (run-frame-top-level frame) (clim-sys:destroy-process ticker-process) - (disconnect-all frame "Client Quit")))))))) + (disconnect-all frame "Client Quit")))) + ;; added process name for easier debug... + :name "BEIRC GUI process")))) + (defun message-directed-to-me-p (message) (irc:destructuring-arguments (&last body) message @@ -396,7 +400,7 @@ (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-close :name t) ((receiver 'receiver :prompt "receiver")) +(define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "tab")) (let* ((connection (connection receiver)) (channel (irc:find-channel connection (title receiver)))) (cond --- /project/beirc/cvsroot/beirc/message-processing.lisp 2006/03/06 10:21:28 1.4 +++ /project/beirc/cvsroot/beirc/message-processing.lisp 2006/03/16 20:32:05 1.5 @@ -67,3 +67,10 @@ "Set/Unset away status." (setf (away-status *application-frame* (irc:connection message)) (typep message 'irc:irc-rpl_noaway-message))) + +(define-beirc-hook autojoin-hoook ((message cl-irc:irc-rpl_welcome-message)) + "When you establish a connection, check the list of channels for autojoin +and set them up accordingly." + (declare (ignore message)) + (join-missing-channels *application-frame*)) + From afuchs at common-lisp.net Thu Mar 16 20:33:36 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 16 Mar 2006 15:33:36 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060316203336.656AA5084@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv13411 Modified Files: application.lisp Log Message: I forgot to mention: the "previous/next page" bindings are derived from a function by Thomas Persson. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 20:32:05 1.61 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 20:33:36 1.62 @@ -438,6 +438,7 @@ if (<= prev (bounding-rectangle-min-y (pane-viewport-region pane)) this) do (return this)) bottom) + (define-scroller-command (com-previous-page (:prior)) (top bottom) (let* ((pane (actual-application-pane (pane (current-receiver *application-frame*)))) (pane-min-y (rectangle-min-y (pane-viewport-region pane))) From afuchs at common-lisp.net Thu Mar 16 20:44:56 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 16 Mar 2006 15:44:56 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060316204456.7F6197089@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv14194 Modified Files: presentations.lisp Log Message: Fix completion in accept method for receivers for multiple server connections. --- /project/beirc/cvsroot/beirc/presentations.lisp 2006/02/25 19:55:56 1.10 +++ /project/beirc/cvsroot/beirc/presentations.lisp 2006/03/16 20:44:56 1.11 @@ -107,7 +107,9 @@ (define-presentation-method accept ((type receiver) *standard-input* (view textual-view) &key) (completing-from-suggestions (*standard-input* :partial-completers '(#\Space)) - (maphash #'suggest (receivers *application-frame*)))) + (maphash (lambda (key receiver) + (suggest (second key) receiver)) + (receivers *application-frame*)))) ;;; channels From afuchs at common-lisp.net Thu Mar 16 20:56:53 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 16 Mar 2006 15:56:53 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060316205653.0F7D178001@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv16566 Modified Files: application.lisp Log Message: Add box-adjuster-gadget between io and the query buffers. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 20:33:36 1.62 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 20:56:52 1.63 @@ -83,7 +83,8 @@ (presence :initform (make-hash-table :test #'equal) :reader presence)) (:panes (io - :interactor) + :interactor + :height 72) (pointer-doc :pointer-documentation) (status-bar :application @@ -111,7 +112,8 @@ (with-tab-layout ('receiver-pane :name 'query) ("*Not Connected*" server 'receiver-pane)) ;; (68 io) ;; no drop-shadow prompt - (72 io) + (make-pane 'clim-extensions:box-adjuster-gadget) + io (20 pointer-doc) (20 ;<-- Sigh! Bitrot! status-bar))))) From afuchs at common-lisp.net Thu Mar 16 21:01:22 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 16 Mar 2006 16:01:22 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060316210122.48EFB79000@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv18270 Modified Files: application.lisp Log Message: Make the quit reason in com-quit an (optional) keyword arg. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 20:56:52 1.63 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 21:01:21 1.64 @@ -573,7 +573,7 @@ (define-beirc-command (com-back :name t) () (irc:away (current-connection *application-frame*) "")) -(define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) +(define-beirc-command (com-quit :name t) (&key (reason 'mumble :prompt "reason" :default "Client Quit")) (disconnect-all *application-frame* reason) (frame-exit *application-frame*)) From afuchs at common-lisp.net Fri Mar 17 17:44:22 2006 From: afuchs at common-lisp.net (afuchs) Date: Fri, 17 Mar 2006 12:44:22 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060317174422.3A0875903A@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv14301 Modified Files: application.lisp Log Message: Add an /Everywhere command, that allows performing another command on every server connection. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 21:01:21 1.64 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/17 17:44:22 1.65 @@ -122,8 +122,17 @@ (defun receiver-from-tab-pane (tab-pane &optional (frame *application-frame*)) (gethash tab-pane (tab-panes-to-receivers frame))) +(defvar *current-receiver-override*) + +(defmacro with-current-receiver ((var receiver) &body body) + `(let* ((*current-receiver-override* ,receiver) + (,var *current-receiver-override*)) + , at body)) + (defmethod current-receiver ((frame beirc)) - (let ((receiver (receiver-from-tab-pane (enabled-pane (find-pane-named frame 'query)) frame))) + (let ((receiver (if (boundp '*current-receiver-override*) + *current-receiver-override* + (receiver-from-tab-pane (enabled-pane (find-pane-named frame 'query)) frame)))) (if (typep receiver 'receiver) receiver nil))) @@ -515,6 +524,12 @@ (make-pathname :type nil :defaults pathname) pathname)))) +(define-beirc-command (com-everywhere :name t) ((command 'command :prompt "command")) + (mapc (lambda (server-receiver) + (with-current-receiver (receiver (cdr server-receiver)) + (execute-frame-command *application-frame* command))) + (server-receivers *application-frame*))) + (defun make-fake-irc-message (message-type &key command arguments (source (current-nickname)) trailing-argument) From rgoldman at common-lisp.net Tue Mar 21 15:22:03 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Tue, 21 Mar 2006 10:22:03 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060321152203.66F8C7A001@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv26475 Modified Files: variables.lisp Log Message: Added *auto-connect-list*, which initially defaults to NIL. As the name suggests, beirc will attempt to connect to these servers automagically on startup. --- /project/beirc/cvsroot/beirc/variables.lisp 2006/02/25 22:22:47 1.10 +++ /project/beirc/cvsroot/beirc/variables.lisp 2006/03/21 15:22:03 1.11 @@ -14,6 +14,12 @@ format: (\"server-name\" . (\"#channel-name\" \"#channel2\" \"#channel3\"))") +(defvar *auto-connect-list* + nil + "A list of servers (strings) specifying servers to which +beirc should automatically connect on startup." +) + (defvar *nickserv-password-alist* '() "Default password to send to the NickServ authentication bot") From rgoldman at common-lisp.net Tue Mar 21 15:23:35 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Tue, 21 Mar 2006 10:23:35 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060321152335.23C2D7A001@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv26685 Modified Files: application.lisp Log Message: Added *auto-connect-list*, which initially defaults to NIL. As the name suggests, beirc will attempt to connect to these servers automagically on startup. Auto-connect is achieved by :after method on adopt-frame added in this file. Idea courtesy of CLIM Guided Tour article. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/17 17:44:22 1.65 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/21 15:23:35 1.66 @@ -582,12 +582,20 @@ (define-beirc-command (com-names :name t) () (irc:names (current-connection *application-frame*) (target))) -(define-beirc-command (com-away :name t) ((reason 'mumble :prompt "reason")) +(define-beirc-command (com-away :name t) ((reason 'mumble + :prompt (if (away-status *application-frame* (current-connection *application-frame*)) + "reason: to come back from away use /back instead of away" + "reason"))) (irc:away (current-connection *application-frame*) reason)) (define-beirc-command (com-back :name t) () (irc:away (current-connection *application-frame*) "")) +(defmethod command-enabled ((command-name (eql 'com-back)) frame) + "Turn off the back command when it's not appropriate -- i.e., when you are +not away." + (away-status frame (current-connection frame))) + (define-beirc-command (com-quit :name t) (&key (reason 'mumble :prompt "reason" :default "Client Quit")) (disconnect-all *application-frame* reason) (frame-exit *application-frame*)) @@ -997,3 +1005,13 @@ (defmethod allocate-space :after ((pane climi::viewport-pane) w h) (let ((pane (first (sheet-children pane)))) (redisplay-frame-pane (pane-frame pane) pane))) + +;;; proposed addition to auto-connect to servers in the +;;; *auto-connect-list* [2006/03/21:rpg] +(defmethod adopt-frame :after (frame-manager (frame beirc)) + (declare (ignore frame-manager)) + (loop for server in *auto-connect-list* + do (execute-frame-command frame + `(com-connect ,server)))) + + From afuchs at common-lisp.net Tue Mar 21 22:45:03 2006 From: afuchs at common-lisp.net (afuchs) Date: Tue, 21 Mar 2006 17:45:03 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060321224503.89E3E3300A@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv21100 Modified Files: presentations.lisp application.lisp Log Message: Make com-close accept a list of receivers; default to the current one. Also, add an explanatory comment about multiple RET hitting to completion. --- /project/beirc/cvsroot/beirc/presentations.lisp 2006/03/16 20:44:56 1.11 +++ /project/beirc/cvsroot/beirc/presentations.lisp 2006/03/21 22:45:03 1.12 @@ -63,14 +63,18 @@ (declare (ignore string)) (present (irc:nickname object) 'nickname :stream stream)) + +;; FIXME: complete-input here and (accept 'command) in +;; read-frame-command means that every command that takes a 'mumble +;; argument must be terminated by hitting RET twice. ugh. (define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key) (with-delimiter-gestures (nil :override t) - (let ((*completion-gestures* '(#\Tab))) - (nth-value 2 - (complete-input *standard-input* 'nickname-completer - #+(or):possibility-printer #+(or) 'nickname-competion-printer - :allow-any-input t - :partial-completers '()))))) + . (let ((*completion-gestures* '(#\Tab))) + (nth-value 2 + (complete-input *standard-input* 'nickname-completer + #+(or):possibility-printer #+(or) 'nickname-competion-printer + :allow-any-input t + :partial-completers '()))))) ;;; nicknames --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/21 15:23:35 1.66 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/21 22:45:03 1.67 @@ -411,17 +411,18 @@ (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-close :name t) ((receiver 'receiver :prompt "tab")) - (let* ((connection (connection receiver)) - (channel (irc:find-channel connection (title receiver)))) - (cond - ((member receiver (server-receivers *application-frame*) :key #'cdr) - (disconnect connection *application-frame* "Client Quit") - (setf (slot-value *application-frame* 'server-receivers) - (delete receiver (server-receivers *application-frame*) :key #'cdr))) - (channel - (irc:part connection channel)))) - (remove-receiver receiver *application-frame*)) +(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)) + (channel (irc:find-channel connection (title receiver)))) + (cond + ((member receiver (server-receivers *application-frame*) :key #'cdr) + (disconnect connection *application-frame* "Client Quit") + (setf (slot-value *application-frame* 'server-receivers) + (delete receiver (server-receivers *application-frame*) :key #'cdr))) + (channel + (irc:part connection channel)))) + (remove-receiver receiver *application-frame*))) (macrolet ((define-scroller-command ((com-name keystroke) (top-var bot-var) next-pos-form &optional fallback-position) `(define-beirc-command (,com-name :name t :keystroke ,keystroke) () From afuchs at common-lisp.net Tue Mar 21 22:50:21 2006 From: afuchs at common-lisp.net (afuchs) Date: Tue, 21 Mar 2006 17:50:21 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060321225021.13F0634049@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv22374 Modified Files: application.lisp Log Message: Make read-frame-command always clear the input window - especially for abort-gesture --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/21 22:45:03 1.67 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/21 22:50:21 1.68 @@ -952,47 +952,47 @@ (call-next-method)) (defmethod read-frame-command ((frame beirc) &key (stream *standard-input*)) - (multiple-value-prog1 - (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))) + (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))) (defun irc-event-loop (frame connection) From afuchs at common-lisp.net Wed Mar 22 00:31:14 2006 From: afuchs at common-lisp.net (afuchs) Date: Tue, 21 Mar 2006 19:31:14 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060322003114.52FCC6D202@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv2592 Modified Files: presentations.lisp Log Message: Remove typo that prevented presentations.lisp from compiling. --- /project/beirc/cvsroot/beirc/presentations.lisp 2006/03/21 22:45:03 1.12 +++ /project/beirc/cvsroot/beirc/presentations.lisp 2006/03/22 00:31:14 1.13 @@ -69,12 +69,12 @@ ;; argument must be terminated by hitting RET twice. ugh. (define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key) (with-delimiter-gestures (nil :override t) - . (let ((*completion-gestures* '(#\Tab))) - (nth-value 2 - (complete-input *standard-input* 'nickname-completer - #+(or):possibility-printer #+(or) 'nickname-competion-printer - :allow-any-input t - :partial-completers '()))))) + (let ((*completion-gestures* '(#\Tab))) + (nth-value 2 + (complete-input *standard-input* 'nickname-completer + #+(or):possibility-printer #+(or) 'nickname-competion-printer + :allow-any-input t + :partial-completers '()))))) ;;; nicknames From afuchs at common-lisp.net Fri Mar 24 21:07:20 2006 From: afuchs at common-lisp.net (afuchs) Date: Fri, 24 Mar 2006 16:07:20 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060324210720.92C0B21004@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv14343 Modified Files: message-display.lisp Log Message: Speed up updating output by storing an sxhashed value. Also, force re-draw of messages that are actually affected by nick focussing and ignore states. --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/12 09:48:57 1.39 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/24 21:07:20 1.40 @@ -53,14 +53,14 @@ (nth-value 1 (decode-universal-time (irc:received-time message))))))))) (updating-output (stream* :cache-value - (list message - (focused-nicks receiver) - (slot-value *application-frame* 'ignored-nicks) - width - *max-preamble-length* - *timestamp-column-orientation* - *default-fill-column*) - :cache-test #'equal) + (sxhash (list message + (message-from-focused-nick-p message receiver) + (message-from-ignored-nick-p message receiver) + width + *max-preamble-length* + *timestamp-column-orientation* + *default-fill-column*)) + :cache-test #'eql) (formatting-row (stream*) (output-timestamp-column :left) (formatting-cell (stream* :align-x :right :min-width '(3 :character)) From rgoldman at common-lisp.net Fri Mar 24 21:19:44 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Fri, 24 Mar 2006 16:19:44 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060324211944.2825621001@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv15877 Modified Files: application.lisp beirc.asd variables.lisp Added Files: post-message-hooks.lisp Log Message: Added support for making noise on certain messages. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/21 22:50:21 1.68 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/24 21:19:43 1.69 @@ -309,25 +309,29 @@ (typep message '(or irc:irc-privmsg-message irc:irc-notice-message irc:irc-topic-message irc:irc-kick-message irc:ctcp-action-message))) (defun post-message-to-receiver (frame message receiver) - (setf (messages receiver) - (append (messages receiver) (list message))) - (unless (eql receiver (current-receiver frame)) - (when (interesting-message-p message) - (incf (unseen-messages receiver))) - (when (message-directed-to-me-p message) - (incf (messages-directed-to-me receiver))) - (incf (all-unseen-messages receiver))) - (when (and (slot-boundp receiver 'pane) (pane receiver)) - (let* ((pane (actual-application-pane (pane receiver))) - (current-insert-position (bounding-rectangle-height pane))) - (when (and (not (eql current-insert-position - (first (positions-mentioning-user receiver)))) - (message-directed-to-me-p message)) - (push current-insert-position - (positions-mentioning-user receiver))))) - (queue-event (frame-top-level-sheet frame) - (make-instance 'foo-event :sheet frame :receiver receiver)) - nil) + (let ((message-to-me-p (message-directed-to-me-p message)) + (interesting-message-p (interesting-message-p message))) + (setf (messages receiver) + (append (messages receiver) (list message))) + (unless (eql receiver (current-receiver frame)) + (when interesting-message-p + (incf (unseen-messages receiver))) + (when message-to-me-p + (incf (messages-directed-to-me receiver))) + (incf (all-unseen-messages receiver))) + (when (and (slot-boundp receiver 'pane) (pane receiver)) + (let* ((pane (actual-application-pane (pane receiver))) + (current-insert-position (bounding-rectangle-height pane))) + (when (and (not (eql current-insert-position + (first (positions-mentioning-user receiver)))) + message-to-me-p) + (push current-insert-position + (positions-mentioning-user receiver))))) + (run-post-message-hooks message frame receiver :message-directed-to-me message-to-me-p + :message-interesting-p interesting-message-p) + (queue-event (frame-top-level-sheet frame) + (make-instance 'foo-event :sheet frame :receiver receiver)) + nil)) (defun post-message (frame message) (let ((receiver (receiver-for-message message frame))) --- /project/beirc/cvsroot/beirc/beirc.asd 2006/03/12 09:48:57 1.7 +++ /project/beirc/cvsroot/beirc/beirc.asd 2006/03/24 21:19:43 1.8 @@ -14,4 +14,6 @@ (:file "presentations" :depends-on ("package" "variables" "receivers")) (:file "message-display" :depends-on ("package" "variables" "presentations")) (:file "application" :depends-on ("package" "variables" "presentations" "events" "receivers")) - (:file "message-processing" :depends-on ("package" "variables" "receivers" "application")))) \ No newline at end of file + (:file "message-processing" :depends-on ("package" "variables" "receivers" "application")) + (:file "post-message-hooks" :depends-on ("package")) + )) \ No newline at end of file --- /project/beirc/cvsroot/beirc/variables.lisp 2006/03/21 15:22:03 1.11 +++ /project/beirc/cvsroot/beirc/variables.lisp 2006/03/24 21:19:44 1.12 @@ -6,7 +6,15 @@ (defvar *default-nick* (format nil "Brucio-~d" (random 100))) (defvar *default-web-browser* #+darwin "/usr/bin/open" ;; assuming a debian system running X: - #+linux "/usr/bin/x-www-browser") + #+linux "/usr/bin/x-www-browser") +(defvar *default-sound-player* + (or nil + #+linux "/usr/bin/ogg123") + "An external program that can be used to produce sounds.") +(defvar *sound-for-my-nick* nil + "If the NOISEMAKER post-message-hook is enabled, and there +is a *default-sound-player* defined, this noise will be +played when your nick is mentioned.") (defvar *auto-join-alist* '(("irc.freenode.net" . ("#beirc"))) "An alist mapping irc server name to a list of channels to --- /project/beirc/cvsroot/beirc/post-message-hooks.lisp 2006/03/24 21:19:44 NONE +++ /project/beirc/cvsroot/beirc/post-message-hooks.lisp 2006/03/24 21:19:44 1.1 (in-package :beirc) (defvar *post-message-hooks* (make-hash-table) "Table of hooks to be run when a message is posted to a receiver.") (defun run-post-message-hooks (message frame receiver &rest args) (maphash #'(lambda (k v) (declare (ignore k)) (apply v message frame receiver args)) *post-message-hooks*) (values)) (defmacro define-post-message-hook (hook-name (message-var frame-var receiver-var &rest other-args) &body body) "Convenience macro for defining hooks that are run when a message is posted to a receiver." `(progn (defun ,hook-name (,message-var ,frame-var ,receiver-var , at other-args &allow-other-keys) , at body) (setf (gethash ',hook-name *post-message-hooks*) ',hook-name))) ;;;--------------------------------------------------------------------------- ;;; If you set *default-sound-player* and *sound-for-my-nick* this ;;; should work... It leaves a lot to be desired. This should ;;; probably turn into some kind of general noisemaking interface... ;;; But this should get us thinking. [2006/03/24:rpg] ;;;--------------------------------------------------------------------------- (define-post-message-hook noisemaker (msg frame receiver &key message-directed-to-me) (declare (ignore msg frame receiver)) (when (and message-directed-to-me *default-sound-player* *sound-for-my-nick*) #+allegro (excl:run-shell-command (format nil "~A ~A" *default-sound-player* *sound-for-my-nick*) :error-output "/dev/null" :if-error-output-exists :append :wait t))) From afuchs at common-lisp.net Mon Mar 27 13:46:47 2006 From: afuchs at common-lisp.net (afuchs) Date: Mon, 27 Mar 2006 08:46:47 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060327134647.75B7D78001@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv15257 Modified Files: application.lisp message-display.lisp message-processing.lisp variables.lisp Log Message: Fix ignore. Make timestamps mouse-sensitive. Fix updating-output. * Ignore and unignore would remove the messages, but not set the scroll state. Make them use the new with-pane-kept-scrolled-to-bottom macro. * Timestamps are now pointers to meme.b9.com on channels that have a user "cmeme" on them. The nickname of the log bot is configurable via *meme-log-bot-nick*. * Updating-output's new SXHASH function would ignore the non-booleans on the list. Ugh. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/24 21:19:43 1.69 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/27 13:46:47 1.70 @@ -254,21 +254,35 @@ (defmethod handle-event ((frame beirc) (event new-sheet-event)) (funcall (sheet-creation-closure event) frame)) +(defmacro with-pane-kept-scrolled-to-bottom ((pane-form) &body body) + "Ensure that the pane in PANE-FORM has the same scroll state +after BODY terminates as it had before: + +If the pane is scrolled to some position before the end, it is +kept there. If the pane is at the bottom of the pane, the +viewport is reset to the then-current bottom after BODY is +finished." + (let ((pane (gensym)) + (bottom-p (gensym))) + `(let* ((,pane ,pane-form) + (,bottom-p (pane-scrolled-to-bottom-p ,pane))) + (multiple-value-prog1 (progn , at body) + (when ,bottom-p (scroll-pane-to-bottom ,pane)))))) + (defmethod handle-event ((frame beirc) (event foo-event)) ;; Hack: ;; Figure out if we are scrolled to the bottom. (let* ((receiver (receiver event)) (pane (actual-application-pane (pane receiver))) (next-event (event-peek (frame-top-level-sheet frame)))) - (let ((btmp (pane-scrolled-to-bottom-p pane))) + (with-pane-kept-scrolled-to-bottom (pane) (update-drawing-options receiver) ;; delay redisplay until this is the last event in the queue ;; (for this event's receiver). (unless (and (typep next-event 'foo-event) (eql (receiver next-event) receiver)) (setf (pane-needs-redisplay pane) t) - (redisplay-frame-panes frame)) - (when btmp (scroll-pane-to-bottom pane))) + (redisplay-frame-panes frame))) (medium-force-output (sheet-medium pane)) ;### )) @@ -496,13 +510,17 @@ (redraw-receiver (current-receiver *application-frame*))) (define-beirc-command (com-ignore :name t) ((who 'nickname :prompt "who")) - (pushnew who (slot-value *application-frame* 'ignored-nicks) :test #'string=) - (redraw-all-receivers)) + (with-pane-kept-scrolled-to-bottom ((actual-application-pane + (pane (current-receiver *application-frame*)))) + (pushnew who (slot-value *application-frame* 'ignored-nicks) :test #'string=) + (redraw-all-receivers))) (define-beirc-command (com-unignore :name t) ((who 'ignored-nickname :prompt "who")) - (setf (slot-value *application-frame* 'ignored-nicks) - (remove who (slot-value *application-frame* 'ignored-nicks) :test #'string=)) - (redraw-all-receivers)) + (with-pane-kept-scrolled-to-bottom ((actual-application-pane + (pane (current-receiver *application-frame*)))) + (setf (slot-value *application-frame* 'ignored-nicks) + (remove who (slot-value *application-frame* 'ignored-nicks) :test #'string=)) + (redraw-all-receivers))) (define-beirc-command (com-unfocus :name t) ((who 'nickname :prompt "who")) (setf (current-focused-nicks) @@ -950,7 +968,7 @@ x y) (declare (ignore object options)) (when (and ptype (presentation-subtypep ptype 'command) - (boundp '*current-input-stream*) *current-input-stream*) + (boundp 'climi::*current-input-stream*) climi::*current-input-stream*) (restart-case (signal 'invoked-command-by-clicking) (acknowledged ())))))))) (call-next-method)) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/24 21:07:20 1.40 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/27 13:46:47 1.41 @@ -38,28 +38,48 @@ (member (irc:source message) (slot-value *application-frame* 'ignored-nicks) :test #'string=)) +(defun +boolean (initial-value &rest booleans) + (loop for value = initial-value then (+ (ash value 1) + (if boolean 1 0)) + for boolean in booleans + finally (return value))) + (defun invoke-formatting-message (stream message receiver preamble-writer message-body-writer) (let* ((*current-message* message) (stream* (if (eql stream t) *standard-output* stream)) (width (- (floor (bounding-rectangle-width (sheet-parent stream*)) (clim:stream-string-width stream* "X")) 2))) - (labels ((output-timestamp-column (position) + (labels ((make-meme-url (message) + (format nil "http://meme.b9.com/cview.html?channel=~A&utime=~A#utime_requested" + (string-trim '(#\#) (channel receiver)) + (irc:received-time message))) + (format-timestamp (message) + (format stream* "[~2,'0D:~2,'0D]" + (nth-value 2 (decode-universal-time (irc:received-time message))) + (nth-value 1 (decode-universal-time (irc:received-time message))))) + (output-timestamp-column (position) (when (eql position *timestamp-column-orientation*) (formatting-cell (stream* :align-x :left) (with-drawing-options (stream* :ink +gray+) - (format stream* "[~2,'0D:~2,'0D]" - (nth-value 2 (decode-universal-time (irc:received-time message))) - (nth-value 1 (decode-universal-time (irc:received-time message))))))))) + (if (and *meme-log-bot-nick* + (irc:find-user (connection receiver) *meme-log-bot-nick*) + (member (title receiver) + (irc:channels (irc:find-user (connection receiver) *meme-log-bot-nick*)) + :test #'equal + :key #'irc:name)) + (with-output-as-presentation (stream* (make-meme-url message) 'url) + (format-timestamp message)) + (format-timestamp message))))))) (updating-output (stream* :cache-value - (sxhash (list message - (message-from-focused-nick-p message receiver) - (message-from-ignored-nick-p message receiver) - width - *max-preamble-length* - *timestamp-column-orientation* - *default-fill-column*)) + (+boolean (sxhash (list message + width + *max-preamble-length* + *default-fill-column*)) + (message-from-focused-nick-p message receiver) + (message-from-ignored-nick-p message receiver) + (eql *timestamp-column-orientation* :left)) :cache-test #'eql) (formatting-row (stream*) (output-timestamp-column :left) --- /project/beirc/cvsroot/beirc/message-processing.lisp 2006/03/16 20:32:05 1.5 +++ /project/beirc/cvsroot/beirc/message-processing.lisp 2006/03/27 13:46:47 1.6 @@ -69,8 +69,13 @@ (typep message 'irc:irc-rpl_noaway-message))) (define-beirc-hook autojoin-hoook ((message cl-irc:irc-rpl_welcome-message)) - "When you establish a connection, check the list of channels for autojoin + "When a connection is established, check the list of channels for autojoin and set them up accordingly." (declare (ignore message)) (join-missing-channels *application-frame*)) +(define-beirc-hook meme-whois-hook ((message irc:irc-rpl_welcome-message)) + "When a connection is established, look up the channels on +which the meme log bot is listening." + (when (not (null *meme-log-bot-nick*)) + (irc:whois (irc:connection message) *meme-log-bot-nick*))) \ No newline at end of file --- /project/beirc/cvsroot/beirc/variables.lisp 2006/03/24 21:19:44 1.12 +++ /project/beirc/cvsroot/beirc/variables.lisp 2006/03/27 13:46:47 1.13 @@ -47,3 +47,6 @@ the command /Close Inactive Queries and the automatic query window closing mechanism (see *auto-close-inactive-query-windows-p*).") + +(defvar *meme-log-bot-nick* "cmeme" + "The name of the meme channel log bot") \ No newline at end of file From afuchs at common-lisp.net Mon Mar 27 21:38:43 2006 From: afuchs at common-lisp.net (afuchs) Date: Mon, 27 Mar 2006 16:38:43 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060327213843.893244005@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv9898 Modified Files: application.lisp Log Message: Add an option to defun beirc to not start a new process. Required if you want to start beirc in a toplevel function --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/27 13:46:47 1.70 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/27 21:38:43 1.71 @@ -295,23 +295,27 @@ ;;; -(defun beirc () +(defun beirc (&key (new-process t)) (let* ((syms '(*package* *trace-output*)) - (vals (mapcar #'symbol-value syms))) - (setf *gui-process* - (clim-sys:make-process - (lambda () - (progv syms vals - (let* ((frame (make-application-frame 'beirc)) - (ticker-process (clim-sys:make-process (lambda () (ticker frame)) - :name "Beirc Ticker"))) - (setf *beirc-frame* frame) - (load-user-init-file) - (run-frame-top-level frame) - (clim-sys:destroy-process ticker-process) - (disconnect-all frame "Client Quit")))) - ;; added process name for easier debug... - :name "BEIRC GUI process")))) + (vals (mapcar #'symbol-value syms)) + (program (lambda () + (progv syms vals + (let* ((frame (make-application-frame 'beirc)) + (ticker-process (clim-sys:make-process (lambda () (ticker frame)) + :name "Beirc Ticker"))) + (setf *beirc-frame* frame) + (load-user-init-file) + (run-frame-top-level frame) + (clim-sys:destroy-process ticker-process) + (disconnect-all frame "Client Quit")))))) + (cond + (new-process + (setf *gui-process* + (clim-sys:make-process program + ;; added process name for easier debug... + :name "BEIRC GUI process"))) + (t (setf *gui-process* (clim-sys:current-process)) + (funcall program))))) (defun message-directed-to-me-p (message) From afuchs at common-lisp.net Mon Mar 27 21:42:41 2006 From: afuchs at common-lisp.net (afuchs) Date: Mon, 27 Mar 2006 16:42:41 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060327214241.E17AC5080@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv9934 Modified Files: beirc.asd message-display.lisp variables.lisp Log Message: Add Thomas Persson's color code interpretation patch. Also, add *filter-colors* --- /project/beirc/cvsroot/beirc/beirc.asd 2006/03/24 21:19:43 1.8 +++ /project/beirc/cvsroot/beirc/beirc.asd 2006/03/27 21:42:41 1.9 @@ -6,7 +6,7 @@ (cl:in-package :beirc.system) (defsystem :beirc - :depends-on (:mcclim :cl-irc :split-sequence :tab-layout) + :depends-on (:mcclim :cl-irc :split-sequence :tab-layout :cl-ppcre) :components ((:file "package") (:file "variables" :depends-on ("package")) (:file "events" :depends-on ("package")) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/27 13:46:47 1.41 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/27 21:42:41 1.42 @@ -7,6 +7,29 @@ (defvar *current-message*) +(defparameter *colors* `((0 . (:ink ,+white+)) + (1 . (:ink ,+black+)) + (2 . (:ink ,+blue+)) + (3 . (:ink ,+green+)) + (4 . (:ink ,+red+)) + (5 . (:ink ,+brown+)) + (6 . (:ink ,+purple+)) + (7 . (:ink ,+orange+)) + (8 . (:ink ,+yellow+)) + (9 . (:ink ,+light-green+)) + (10 . (:ink ,+dark-cyan+)) + (11 . (:ink ,+cyan+)) + (12 . (:ink ,+royal-blue+)) + (13 . (:ink ,+pink+)) + (14 . (:ink ,+grey+)) + (15 . (:ink ,+light-grey+)) + ("" . (normal)) + ("" . (underline)) + ("" . (inverse)) + ("" . (bold)))) + +(defparameter *color-scanner* (cl-ppcre:create-scanner "[0-9]{1,2}(,[0-9]{1,2}){0,1}||||")) + (define-presentation-type url () :inherit-from 'string) @@ -124,32 +147,138 @@ (string first-char))) (otherwise (values word "")))))) +(defun extract-color (string) + (multiple-value-bind (start end) + (cl-ppcre:scan *color-scanner* + string) + (if start + (let* ((message (subseq string end)) + (color-code (subseq string start end)) + (color-code (or (cl-ppcre:all-matches-as-strings "[0-9]{1,2}" + color-code) + (list (cl-ppcre:scan-to-strings "|||" + color-code)))) + (foreground (or (parse-integer (car color-code) + :junk-allowed t) + (car color-code))) + (background (when (cadr color-code) + (parse-integer (cadr color-code) + :junk-allowed t))) + (foreground (cdr (assoc foreground + *colors* + :test #'equal))) + (background (cdr (assoc background + *colors* + :test #'equal)))) + (values message + foreground + background + )) + string))) + +(defun split-before (delimiter string) + (let ((matches (cl-ppcre:all-matches delimiter string))) + (if matches + (loop for (a b c) on matches by #'cddr + collecting (subseq string a c) into strings + finally (return (if (zerop (car matches)) + strings + (cons (subseq string + 0 + (car matches)) + strings)))) + (list string)))) + +(defmacro do-colored-string ((string-var str) &body body) + `(dolist (part (split-before *color-scanner* ,str)) + (multiple-value-bind (message foreground background) + (extract-color part) + (cond (*filter-colors* nil) + ((equal (car foreground) + 'normal) + (setf foreground-color +black+ + background-color +white+)) + ((equal (car foreground) + :ink) + (setf foreground-color + (cadr foreground)) + (when background + (setf background-color (cadr background)))) + ((equal (car foreground) + 'bold) + (setf bold (if bold nil :bold))) + ((equal (car foreground) + 'underline) + (setf underline (not underline))) + ((equal (car foreground) + 'inverse) + (setf inverse (not inverse)))) + (with-drawing-options (t :text-face bold) + (let ((,string-var message)) + (if inverse + (with-irc-colors (background-color foreground-color underline) + , at body) + (with-irc-colors (foreground-color background-color underline) + , at body))))))) + +(defmacro with-irc-colors ((foreground background underlinep) &body body) + `(with-sheet-medium (medium *standard-output*) + (let ((record (with-new-output-record (t) + (with-drawing-options (t :ink ,foreground) + , at body)))) + (with-bounding-rectangle* (left top right bottom) + record + (unless (equal left right) + (unless (equal ,background +white+) + (with-identity-transformation (medium) + (draw-rectangle* *standard-output* + left + top + right + bottom + :filled t + :ink ,background) + (replay-output-record record *standard-output*) + (setf (stream-cursor-position *standard-output*) + (values right top)))) + (when ,underlinep + (draw-line* *standard-output* left (- bottom 1) + (- right 1) (- bottom 1) + :ink ,foreground))) + record)))) + (defun format-message* (mumble &key (limit *default-fill-column*) (start-length 0)) - (loop for (word . rest) on (split-sequence:split-sequence #\Space mumble) - with column = start-length - do (incf column (length word)) - when (> column limit) - do (setf column (length word)) - (terpri) - do (multiple-value-bind (%word stripped-preceding-punctuation) (strip-preceding-punctuation word) - (multiple-value-bind (word% stripped-punctuation) (strip-punctuation %word) - (write-string stripped-preceding-punctuation) - (cond - ((or (search "http://" word%) (search "https://" word%)) - (present-url word%)) - ((or - (nick-equals-my-nick-p word% (irc:connection *current-message*)) - (and (current-connection *application-frame*) - (irc:find-user (current-connection *application-frame*) word%))) - (present word% 'nickname)) - ((channelp word%) (present word% 'channel)) - (t (write-string word%))) - (write-string stripped-punctuation))) - ;; TODO: more highlighting - unless (or (null rest) (>= column limit)) - do (write-char #\Space) - (incf column)) - (terpri)) + (let ((foreground-color (medium-foreground *standard-output*)) + (background-color (medium-background *standard-output*)) + (bold nil) + (underline nil) + (inverse nil)) + (let ((column start-length)) + (loop for (word . rest) on (split-sequence:split-sequence #\Space mumble) + do (do-colored-string (word word) + (incf column (length word)) + (when (> column limit) + (setf column (length word)) + (terpri)) + (multiple-value-bind (%word stripped-preceding-punctuation) (strip-preceding-punctuation word) + (multiple-value-bind (word% stripped-punctuation) (strip-punctuation %word) + (write-string stripped-preceding-punctuation) + (cond + ((or (search "http://" word%) (search "https://" word%)) + (present-url word%)) + ((or + (nick-equals-my-nick-p word% (irc:connection *current-message*)) + (and (current-connection *application-frame*) + (irc:find-user (current-connection *application-frame*) word%))) + (present word% 'nickname)) + ((channelp word%) (present word% 'channel)) + (t (write-string word%))) + (write-string stripped-punctuation)))) + do (unless (or (null rest) (>= column limit)) + (do-colored-string (s " ") + (write-string s) + (incf column)))) + (terpri)))) ;;; privmsg-like messages --- /project/beirc/cvsroot/beirc/variables.lisp 2006/03/27 13:46:47 1.13 +++ /project/beirc/cvsroot/beirc/variables.lisp 2006/03/27 21:42:41 1.14 @@ -49,4 +49,8 @@ *auto-close-inactive-query-windows-p*).") (defvar *meme-log-bot-nick* "cmeme" - "The name of the meme channel log bot") \ No newline at end of file + "The name of the meme channel log bot") + +(defvar *filter-colors* nil + "If set to non-NIL, filter color, bold, inverse and underline +codes from IRC messages.") \ No newline at end of file From afuchs at common-lisp.net Mon Mar 27 21:46:31 2006 From: afuchs at common-lisp.net (afuchs) Date: Mon, 27 Mar 2006 16:46:31 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060327214631.65C21706B@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv11414 Modified Files: message-display.lisp Log Message: use medium-ink instead of medium-foreground to find the ink color. --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/27 21:42:41 1.42 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/27 21:46:31 1.43 @@ -248,7 +248,7 @@ record)))) (defun format-message* (mumble &key (limit *default-fill-column*) (start-length 0)) - (let ((foreground-color (medium-foreground *standard-output*)) + (let ((foreground-color (medium-ink *standard-output*)) (background-color (medium-background *standard-output*)) (bold nil) (underline nil)