Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv17598

Modified Files: application.lisp beirc.asd message-display.lisp Added Files: message-processing.lisp Log Message: factor out (and clean up) message processing from application.lisp and implement away status tracking.

--- /project/beirc/cvsroot/beirc/application.lisp 2006/02/26 15:53:30 1.46 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/26 18:41:21 1.47 @@ -74,7 +74,8 @@ (ignored-nicks :initform nil) (receivers :initform (make-hash-table :test #'equal) :accessor receivers) (server-receivers :initform nil :reader server-receivers) - (tab-panes-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-panes-to-receivers)) + (tab-panes-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-panes-to-receivers) + (presence :initform (make-hash-table :test #'equal) :reader presence)) (:panes (io :interactor) @@ -143,6 +144,11 @@ (setf (slot-value *application-frame* 'connection-processes) (delete connection (connection-processes *application-frame*) :key #'car)))

+(defmethod away-status ((frame beirc) connection) + (gethash connection (presence frame))) + +(defmethod (setf away-status) (newval (frame beirc) connection) + (setf (gethash connection (presence frame)) newval))

(defmethod current-nickname (&optional (connection (current-connection *application-frame*))) (let ((user (when connection @@ -160,9 +166,10 @@ (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 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*)) (current-channel) (current-query) (length (current-messages)))))) @@ -786,7 +793,7 @@ (irc:quit connection reason) (when (not (eql (clim-sys:current-process) (connection-process frame connection))) - (destroy-process (print (connection-process frame connection) *debug-io*))) + (destroy-process (connection-process frame connection))) (remove-connection-process frame connection))))

(defun disconnect-all (frame reason) @@ -817,64 +824,6 @@ object))) (window-clear stream)))

-(defun restart-beirc () - (clim-sys:destroy-process *gui-process*) - (setf *beirc-frame* nil) - (beirc) - (clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*))) - - -;;;;;;;;; - -(defmethod process-message (*application-frame* (message irc:irc-ping-message)) -; (describe message *trace-output*) -; (finish-output *trace-output*) - ;; ### - (irc:pong (current-connection *application-frame*) "localhost") - nil) ;### put the server you initially connected to here. - -(defmethod trailing-argument* (message) - (car (last (irc:arguments message)))) - -(defmethod trailing-argument* ((message cl-irc:ctcp-action-message)) - (or - (ignore-errors ;### - (let ((p1 (position #\space (car (last (irc:arguments message)))))) - (subseq (car (last (irc:arguments message))) - (1+ p1) - (1- (length (car (last (irc:arguments message)))))))) - "#Garbage parsing message#")) - -(defmethod process-message (*application-frame* (message cl-irc:ctcp-action-message)) -; (describe message *trace-output*) -; (print (trailing-argument* message) *trace-output*) - ) - -(defmethod process-message (*application-frame* message) -; (describe message *trace-output*) -; (finish-output *trace-output*) - nil) - -(defclass beirc-connection (irc:connection) - ()) - -(defmethod preprocess-message ((connection beirc-connection) (message irc:irc-nick-message)) - (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))) - - (irc:normalized-nickname (irc:user (irc:connection message))) - (irc:normalize-nickname connection (car (last (irc:arguments message))))))) - -(defmethod preprocess-message (connection message) - nil) - -(defmethod irc::irc-message-event :around ((connection beirc-connection) message) - (preprocess-message connection message) - (post-message *application-frame* message) - (call-next-method)) - (defun irc-event-loop (frame connection) (unwind-protect (let ((*application-frame* frame)) --- /project/beirc/cvsroot/beirc/beirc.asd 2005/09/25 15:48:32 1.5 +++ /project/beirc/cvsroot/beirc/beirc.asd 2006/02/26 18:41:21 1.6 @@ -12,4 +12,5 @@ (:file "receivers" :depends-on ("package" "variables")) (:file "presentations" :depends-on ("package" "variables" "receivers")) (:file "message-display" :depends-on ("package" "variables" "presentations")) - (:file "application" :depends-on ("package" "variables" "presentations" "receivers")))) \ No newline at end of file + (:file "application" :depends-on ("package" "variables" "presentations" "receivers")) + (:file "message-processing" :depends-on ("package" "variables" "receivers" "application")))) \ No newline at end of file --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/25 19:55:56 1.36 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/26 18:41:21 1.37 @@ -133,6 +133,18 @@

;;; privmsg-like messages

+(defmethod trailing-argument* (message) + (car (last (irc:arguments message)))) + +(defmethod trailing-argument* ((message cl-irc:ctcp-action-message)) + (or + (ignore-errors ;### + (let ((p1 (position #\space (car (last (irc:arguments message)))))) + (subseq (car (last (irc:arguments message))) + (1+ p1) + (1- (length (car (last (irc:arguments message)))))))) + "#Garbage parsing message#")) + (defun print-privmsg-like-message (message receiver start-string end-string) (with-drawing-options (*standard-output*

--- /project/beirc/cvsroot/beirc/message-processing.lisp 2006/02/26 18:41:21 NONE +++ /project/beirc/cvsroot/beirc/message-processing.lisp 2006/02/26 18:41:21 1.1 (in-package :beirc)

;;; Functions and protocols related to message processing in beirc.

;;; Incoming IRC messages are caught by specializing ;;; irc:irc-message-event, which processes messages in this way: ;;; ;;; 1. The message is preprocessed by preprocess-message. ;;; 2. The message is posted to the application frame. ;;; 3. The message is processed by cl-irc's hooks.

(defvar *beirc-message-hooks* (make-hash-table))

(defclass beirc-connection (irc:connection) ())

(defmethod initialize-instance :after ((instance beirc-connection) &rest initargs) (declare (ignore initargs)) (loop for hooks being the hash-values in *beirc-message-hooks* using (hash-key message-class) do (loop for hook in hooks do (irc:add-hook instance message-class hook))))

(defmethod irc:irc-message-event :around ((connection beirc-connection) message) "Dispatch IRC messages to Beirc for display before cl-irc mangles the channel/connection/user state." (preprocess-message connection message) (post-message *application-frame* message) (call-next-method))

;;; 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)))

(irc:normalized-nickname (irc:user (irc:connection message))) (irc:normalize-nickname connection (car (last (irc:arguments message)))))))

(defmethod preprocess-message (connection message) nil)

;;; Traditional cl-irc message hooks

(defmacro define-beirc-hook (hook-name ((message-var &rest message-types)) &body body) "Convenience macro for defining message hooks that are added at connection instantiation time." `(progn (defun ,hook-name (,message-var) ,@body) ,@(loop for message-type in message-types collect `(pushnew ',hook-name (gethash ',message-type *beirc-message-hooks*))) ',hook-name))

(define-beirc-hook update-away-status ((message irc:irc-rpl_noaway-message irc:irc-rpl_unaway-message)) "Set/Unset away status." (print (away-status *application-frame* (irc:connection message)) *debug-io*) (setf (away-status *application-frame* (irc:connection message)) (typep message 'irc:irc-rpl_noaway-message)))