[beirc-cvs] CVS beirc
afuchs
afuchs at common-lisp.net
Sun Feb 26 18:41:21 UTC 2006
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) , at 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)))
More information about the Beirc-cvs
mailing list