Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv18453
Modified Files: beirc.lisp message-display.lisp Log Message: implement kicking & banning; reorder and group print-message methods
Date: Sat Sep 24 21:03:15 2005 Author: afuchs
Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.26 beirc/beirc.lisp:1.27 --- beirc/beirc.lisp:1.26 Sat Sep 24 20:14:28 2005 +++ beirc/beirc.lisp Sat Sep 24 21:03:14 2005 @@ -163,18 +163,29 @@ (define-global-message-receiver-lookup irc:irc-quit-message) (define-global-message-receiver-lookup irc:irc-nick-message))
-(defmethod receiver-for-message ((message irc:irc-topic-message) frame) - (intern-receiver (first (irc:arguments message)) frame :channel (first (irc:arguments message)))) +(macrolet ((define-nth-arg-message-receiver-lookup (&rest clauses) + "Defines receiver-for-message methods that return + the receiver associated with the nth arg of the + irc message or the trailing arg if NTH in the + clauses is nil.
-(defmethod receiver-for-message ((message irc:irc-rpl_topic-message) frame) - (intern-receiver (second (irc:arguments message)) frame :channel (second (irc:arguments message)))) - -(defmethod receiver-for-message ((message irc:irc-rpl_namreply-message) frame) - (intern-receiver (third (irc:arguments message)) frame :channel (third (irc:arguments message)))) - -(defmethod receiver-for-message ((message irc:irc-join-message) frame) - (let ((target (irc:trailing-argument message))) - (intern-receiver target frame :channel target))) + Each clause must have this format: + (nth message-type ...)" + `(progn + ,@(loop for (nth . messages) in clauses + do (print messages) + nconc (loop for message-type in messages + collect + `(defmethod receiver-for-message ((message ,message-type) frame) + (let ((target ,(if (numberp nth) + `(nth ,nth (irc:arguments message)) + `(irc:trailing-argument message)))) + (intern-receiver target frame :channel target)))))))) + (define-nth-arg-message-receiver-lookup + (0 irc:irc-topic-message irc:irc-kick-message) + (1 irc:irc-rpl_topic-message) + (2 irc:irc-rpl_namreply-message) + (nil irc:irc-join-message)))
(defmethod receiver-for-message ((message irc:irc-part-message) frame) (let ((target (first (irc:arguments message)))) @@ -440,6 +451,8 @@ (define-presentation-type nickname ()) (define-presentation-type unhighlighted-nickname () :inherit-from 'nickname) (define-presentation-type ignored-nickname () :inherit-from 'nickname) +(define-presentation-type channel () :inherit-from 'string) +(define-presentation-type hostmask () :inherit-from 'string)
(defun hash-alist (hashtable &aux res) (maphash (lambda (k v) (push (cons k v) res)) hashtable) @@ -465,6 +478,11 @@ (receiver-from-tab-pane (find-in-tab-panes-list object 'tab-layout-pane)))
+(define-presentation-translator nickname-to-hostmask-translator + (nickname hostmask beirc) + (object) + (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object)))) + (defun nick-equals-my-nick-p (nickname) (and (not (null *application-frame*)) (not (null (slot-value *application-frame* 'connection))) @@ -483,8 +501,6 @@ (write-string o))) (write-string o)))
-(define-presentation-type channel () :inherit-from 'string) - (define-presentation-method presentation-typep (object (type channel)) (channelp object))
@@ -567,6 +583,15 @@ (define-beirc-command (com-deop :name t) ((who 'nickname :prompt "who")) (irc:deop (current-connection *application-frame*) (target) who))
+(define-beirc-command (com-ban-nick :name t) ((who 'nickname :prompt "who")) + (irc:ban (current-connection *application-frame*) (target) (format nil "~A!*@*" who))) + +(define-beirc-command (com-ban-hostmask :name t) ((who 'hostmask :prompt "hostmask")) + (irc:ban (current-connection *application-frame*) (target) who)) + +(define-beirc-command (com-kick :name t) ((who 'nickname :prompt "who")) + (irc:kick (current-connection *application-frame*) (target) who)) + (define-beirc-command (com-names :name t) () (irc:names (current-connection *application-frame*) (target)))
@@ -662,8 +687,8 @@ (clim-sys:make-process #'(lambda () (unwind-protect (irc-event-loop frame connection) - (disconnect frame))) - :name "IRC Message Muffling Loop")) ))))) + (quit frame "IRC event loop terminated."))) + :name "IRC Message Muffling Loop")))))))
(defun disconnect (frame) (raise-receiver (server-receiver frame))
Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.11 beirc/message-display.lisp:1.12 --- beirc/message-display.lisp:1.11 Sat Sep 24 20:13:44 2005 +++ beirc/message-display.lisp Sat Sep 24 21:03:15 2005 @@ -114,6 +114,8 @@ (incf column)) (terpri))
+;;; privmsg-like messages + (defun print-privmsg-like-message (message receiver start-string end-string) (with-drawing-options (*standard-output* @@ -145,6 +147,22 @@ (format t " ") (format-message* matter :start-length (+ 2 (length source)))))))
+;;; server messages + +(defmethod print-message ((message irc:irc-rpl_motd-message) receiver) + (formatting-message (t message receiver) + ((format t "~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "MOTD: ~A" (irc:trailing-argument message)))))) + +(defmethod print-message (message receiver) + (formatting-message (t message receiver) + ((format t "!!! ~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) + (format t "args: ~A :~A" (irc:arguments message) (irc:trailing-argument message)))))) + +;;; user-related messages + (defmethod print-message ((message irc:irc-quit-message) receiver) (formatting-message (t message receiver) ((format t " ")) @@ -155,22 +173,16 @@ (format-message* (irc:trailing-argument message) :start-length (+ 8 (length (irc:source message))))))))
-(defmethod print-message ((message irc:irc-join-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Join: ") - (present (irc:source message) 'nickname) - (format t " (~A@~A)" (irc:user message) (irc:host message)))))) - (defmethod print-message ((message irc:irc-nick-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Nick change: ") - (present (irc:source message) 'nickname) - (format t " (~A@~A) is now known as " (irc:user message) (irc:host message)) - (present (irc:trailing-argument message) 'nickname))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Nick change: ") + (present (irc:source message) 'nickname) + (format t " (~A@~A) is now known as " (irc:user message) (irc:host message)) + (present (irc:trailing-argument message) 'nickname))))) + +;;; channel management messages
(defun print-topic (receiver message sender channel topic) (formatting-message (t message receiver) @@ -205,6 +217,25 @@ (present (irc:source message) 'nickname) (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message))))))
+(defmethod print-message ((message irc:irc-join-message) receiver) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Join: ") + (present (irc:source message) 'nickname) + (format t " (~A@~A)" (irc:user message) (irc:host message)))))) + +(defmethod print-message ((message irc:irc-kick-message) receiver) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (irc:source message) 'nickname) + (write-string " kicked ") + (present (second (irc:arguments message)) 'nickname) + (format-message* (format nil ": ~A" (irc:trailing-argument message)) + :start-length (+ 9 (length (second (irc:arguments message))) + (length (irc:source message)))))))) + (defmethod print-message ((message irc:irc-mode-message) receiver) (case (length (irc:arguments message)) (1 (formatting-message (t message receiver) @@ -221,17 +252,7 @@ (present (irc:source message) 'nickname) (format-message* (format nil " set mode ~A ~A" modes args)))))))))
-(defmethod print-message ((message irc:irc-rpl_motd-message) receiver) - (formatting-message (t message receiver) - ((format t "~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "MOTD: ~A" (irc:trailing-argument message)))))) - -(defmethod print-message (message receiver) - (formatting-message (t message receiver) - ((format t "!!! ~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) - (format t "args: ~A :~A" (irc:arguments message) (irc:trailing-argument message)))))) +;;; the display function (& utilities)
(defgeneric preamble-length (message) (:method ((message irc:irc-privmsg-message)) @@ -247,30 +268,4 @@ maximize (preamble-length message)))) (formatting-table (t) (loop for message in messages - do (print-message message receiver))))) - - -#| - (let ((k 100) - (n (length messages))) - (loop for i below (* k (ceiling n k)) by k do - (updating-output (*standard-output* - :unique-id i - :cache-value - (list (min n (+ i k)) - (focused-nicks receiver) - (slot-value *application-frame* 'ignored-nicks) - w) - :cache-test #'equal) - (loop for j from i below (min n (+ i k)) do - (let ((m (elt messages j))) - (updating-output (*standard-output* - :unique-id j - :cache-value - (list m - (focused-nicks receiver) - (slot-value *application-frame* 'ignored-nicks) - w) - :cache-test #'equal) - (print-message m receiver))))))) -|# \ No newline at end of file + do (print-message message receiver))))) \ No newline at end of file